News:

BB code in posts seems to be working again!
I haven't turned on every single tag, so please let me know if there are any that are used/needed but not activated.

Main Menu

Instant Isometrics

Started by JuneTheSecond, February 19, 2017, 06:33:45 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

JuneTheSecond

Here is a VBA macro that converts a normal orthogonal shape into isometric.


Option Explicit


Sub Orth2Iso()
    Dim shp As Visio.Shape
    Dim hgt As Double
    Dim crnr As Double
    Dim dirc As Double
    Dim yn As Long
    Dim iRowData As Integer

   
    Set shp = ActiveWindow.Selection(1)
    crnr = InputBox("Enter corner radius in mm", "Corner", 0)
    yn = MsgBox("View frm right ?", vbYesNo, "View Direction")
    shp.CellsSRC(visSectionObject, visRowLine, visLineRounding).FormulaU = crnr & " mm"
    If yn = vbYes Then
        dirc = -45#
    Else
        dirc = 45#
    End If
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = dirc & " deg"
    ActiveWindow.Selection.Join
    Set shp = ActiveWindow.Selection(1)
    hgt = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).Result(visMillimeters)
    hgt = hgt * Sqr(3#) / 3#
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = hgt & " mm"
    iRowData = shp.AddRow(visSectionProp, visRowLast, visTagDefault)
    shp.Section(visSectionProp).Row(iRowData).NameU = "direction"
    shp.CellsSRC(visSectionProp, iRowData, visCustPropsLabel).FormulaU = """View Direction"""
    If yn = vbYes Then
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From right"""
    Else
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From left"""
    End If
End Sub



In this macro you can define a corner radius and a view direction, left or right.
The corners are automatically converted into real arcs.

And here is more one macro to reversely convert the isometric shape made by above macro into orthogonal shape. The corners cannot be restored into rectangles.



Sub Iso2Orth()
    Dim shp As Visio.Shape
    Dim hgt As Double
    Dim dirc As String
   
    Set shp = ActiveWindow.Selection(1)
    hgt = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).Result(visMillimeters)
    hgt = hgt * 3# / Sqr(3#)
    dirc = shp.Cells("Prop.direction").FormulaU
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = hgt & " mm"
    If dirc = """From right""" Then
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = "45 deg"
    Else
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = "-45 deg"
    End If
    ActiveWindow.Selection.Join

End Sub
Best Regards,

Junichi Yoda
http://june.minibird.jp/

Yacine

Yacine

vojo

great work!!!

Just a suggestion, but it would be great to convert control points as well and possibly covert or overwrite
formulas for ISO behavior.  Even if its just 2 (width, depth of shape) or even 3 (width, depth, height of shape
...height might be "same shape xx mm up - control point - from original and connected to original")

I know people have built ISO shapes up from scratch and added ISO control points
But if somebody has an generic ORTHO shape with some control points, including control points might be helpful
(would make this a more thorough solution than MS ISO transformation in Visio 2013)

But great piece of work!!!


vojo

or even add props fields to numerically (abs number or % or or or) adjust width and depth and maybe height

Again great work

JuneTheSecond

#4
Thank you. It is nice to share good idea.
By the way I've tried to add a text to the shape.
The macro is modified just a little.

You need to install isometric fonts that were included in piping  isometric stencil.


Option Explicit


Sub Orth2Iso()
    Dim shp As Visio.Shape
    Dim hgt As Double
    Dim crnr As Double
    Dim dirc As Double
    Dim yn As Long
    Dim iRowData As Integer

   
    Set shp = ActiveWindow.Selection(1)
    crnr = InputBox("Enter corner radius in mm", "Corner", 0)
    yn = MsgBox("View frm right ?", vbYesNo, "View Direction")
    shp.CellsSRC(visSectionObject, visRowLine, visLineRounding).FormulaU = crnr & " mm"
    If yn = vbYes Then
        dirc = -45#
    Else
        dirc = 45#
    End If
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = dirc & " deg"
    ActiveWindow.Selection.Join
    Set shp = ActiveWindow.Selection(1)
    hgt = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).Result(visMillimeters)
    hgt = hgt * Sqr(3#) / 3#
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = hgt & " mm"
    iRowData = shp.AddRow(visSectionProp, visRowLast, visTagDefault)
    shp.Section(visSectionProp).Row(iRowData).NameU = "direction"
    shp.CellsSRC(visSectionProp, iRowData, visCustPropsLabel).FormulaU = """View Direction"""
    If yn = vbYes Then
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From right"""
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "Font(""Isome_Right"")"
        shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormAngle).FormulaU = "-30 deg"
    Else
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From left"""
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "Font(""Isome_Left"")"
        shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormAngle).FormulaU = "30 deg"
    End If
   

End Sub

Sub Iso2Orth()
    Dim shp As Visio.Shape
    Dim hgt As Double
    Dim dirc As String
   
    Set shp = ActiveWindow.Selection(1)
    hgt = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).Result(visMillimeters)
    hgt = hgt * 3# / Sqr(3#)
    dirc = shp.Cells("Prop.direction").FormulaU
    shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = hgt & " mm"
    If dirc = """From right""" Then
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = "45 deg"
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "THEMEVAL()"
        shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormAngle).FormulaU = "-30 deg"
    Else
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormAngle).FormulaU = "-45 deg"
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "THEMEVAL()"
        shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormAngle).FormulaU = "30 deg"
    End If
    ActiveWindow.Selection.Join

End Sub



Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

And here is a zipped file for isometric fonts.
May be you can install the fonts by right-button-cliking of mouse on each font file,
and selecting install.
Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

The calculation of text pin point on isometric shape is not easy.
I've tried it, but it is far from complete result.
This is a part of the  macro to decide the location of the pin point of the text.
I wish Visio has a set of miracle fonts that varies as one of Visio shapes.



'(7) Moving tha text on the shape.

    PinX2 = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).Result(visMillimeters)
    PinY2 = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).Result(visMillimeters)
    d = PinY2 - PinY1
    If yn = vbYes Then
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From right"""
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "Font(""Isome_Right"")"
        txtpinx = PinX1 + (Sqr(2#) / 2#) * (xtxt + ytxt)
        txtpiny = PinY1 + (Sqr(3#) / 3#) * (((Sqr(2#) / 2#) * (-xtxt + ytxt)) + (Sqr(2#) / 2#) * d)
    Else
        shp.CellsSRC(visSectionProp, iRowData, visCustPropsValue).FormulaU = """From left"""
        shp.CellsSRC(visSectionCharacter, 0, visCharacterFont).FormulaU = "Font(""Isome_Left"")"
        txtpinx = PinX1 + (Sqr(2#) / 2#) * (xtxt - ytxt)
        txtpiny = PinY1 + (Sqr(3#) / 3#) * (((Sqr(2#) / 2#) * (xtxt + ytxt)) + (Sqr(2#) / 2#) * d)
    End If
   

    txtX = txtpinx - PinX2 + wdt * 0.5
    txtY = txtpiny - PinY2 + hgt * 0.5
         
    txtX = txtX / wdt
    txtY = txtY / hgt
    shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormPinX).FormulaU = "Width*" & txtX
    shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormPinY).FormulaU = "Height*" & txtY

    shp.CellsSRC(visSectionObject, visRowTextXForm, visXFormAngle).FormulaU = txtang2(txtang, dirc) & " deg"
    HtText = shp.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU
 
Best Regards,

Junichi Yoda
http://june.minibird.jp/

Yacine

#7
Cool.
I needed however to replace the formula assignments by "replace(formula,".",",") (German OS-settings --> pain in the proverbial | or Visio not able to handle properly dots and commas)
And my text did not get inclined as yours. ;)
Yacine

JuneTheSecond

Thank you for viewing.
Please use special fonts for isometrics uploaded at the place above 3 or 4 comments from your comment.
Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

#9
I am trying find another way to decide the text pin point on an isometric shape
without complicated calculation.
One idea is to use dummy line to start from the text pin point.

'(3) Add a short line at the text pin point

    Isec = shp.AddSection(visSectionLastComponent)
    shp.AddRow Isec, visRowComponent, visTagComponent
    shp.AddRow Isec, visRowVertex, visTagLineTo
    shp.AddRow Isec, visRowVertex, visTagMoveTo
    shp.CellsSRC(Isec, 1, 0).FormulaU = "TxtPinX"
    shp.CellsSRC(Isec, 1, 1).FormulaU = "TxtPinY"
    shp.CellsSRC(Isec, 2, 0).FormulaU = "TxtPinX+5mm"
    shp.CellsSRC(Isec, 2, 1).FormulaU = "TxtPinY+5mm"

Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

Added a modified drawing with a new macro.
And a short video for description at
https://youtu.be/u4mk7wqsl3U .
Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

#11
Enjoy Instant Isometrics for another shape.
And here is a short movie.
https://youtu.be/QKbvEoi2fLk
Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

New VBA macro is added that convert more mathematically the orthogonal geometries into isometric.
The elliptical arc is not converted exactly, as I did not use that very complicated formulas to get the slant angle and the aspect ratio.  However I can reduce the error, if the arc is short,  or by breaking down the long arc into the assembly of short arcs with the Visio pencil tool.
Now we can convert the many complicated geometric shapes into the isometric shapes at once togather.
Here is a short movie to describe how the macro works at
https://youtu.be/peHgMXCnSJA
Best Regards,

Junichi Yoda
http://june.minibird.jp/

JuneTheSecond

Now, totally revised VBA macro is ready.
In this macro all the geometries in a shape is rotated by means of mathematical coordinate rotation.
Elliptical arc and nurbs curves are included in this macro. And then the height of the shape is compressed by sqrt(3).
Here is a short video at  https://youtu.be/goa1Zs-FLow.
please enjoy.
Best Regards,

Junichi Yoda
http://june.minibird.jp/

wapperdude

Visio 2019 Pro

Browser ID: smf (possibly_robot)
Templates: 4: index (default), Display (default), GenericControls (default), GenericControls (default).
Sub templates: 6: init, html_above, body_above, main, body_below, html_below.
Language files: 4: index+Modifications.english (default), Post.english (default), Editor.english (default), Drafts.english (default).
Style sheets: 4: index.css, attachments.css, jquery.sceditor.css, responsive.css.
Hooks called: 402 (show)
Files included: 34 - 1306KB. (show)
Memory used: 1287KB.
Tokens: post-login.
Cache hits: 16: 0.00197s for 26,731 bytes (show)
Cache misses: 5: (show)
Queries used: 15.

[Show Queries]