Instant Isometrics

[JuneTheSecond]

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

Code

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.

Code

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

[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]

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.

Code

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

[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.

[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.

Code

'(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
  

[Yacine]

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.

[JuneTheSecond]

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

[JuneTheSecond]

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.

Code

'(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"

[JuneTheSecond]

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

[JuneTheSecond]

Enjoy Instant Isometrics for another shape.
And here is a short movie.
https://youtu.be/QKbvEoi2fLk

[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

[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.
 

[wapperdude]

WOW

Wapperdude