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
*****!
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!!!
or even add props fields to numerically (abs number or % or or or) adjust width and depth and maybe height
Again great work
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
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.
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
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. ;)
Thank you for viewing.
Please use special fonts for isometrics uploaded at the place above 3 or 4 comments from your comment.
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"
Added a modified drawing with a new macro.
And a short video for description at
https://youtu.be/u4mk7wqsl3U .
Enjoy Instant Isometrics for another shape.
And here is a short movie.
https://youtu.be/QKbvEoi2fLk
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
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.
WOW
Wapperdude
A bug that makes twist the shape has been fixed.
If the last row of a geometry section refers to the first row,
the last row moved twice to the new location.
Though this macro is practically quite useless, now I feel it gave me an opportunity to study about elliptical arc and nurbs function deeper than before.
Thank you everybody. :) :) :)
Here is a VBA macro that makes a grouped shapes isometric style, and their shaped examples.
Haven't checked if you implemented it yet (sorry for my lazyness), but I think that the isometric angle is very important for implementing a viable flexible solution. In a previous project I used to work with both 0/90/45 and 0/60/60.
As a generalisation one may think of generic "free" angles as well.
Just a thought. Sorry.
Thank you, Yacine for your always good advice.
Any way it is a big challenge to me, I shall study more.
Here is another trial VBA macro.
This macro simply convert a one-dimensional shape into two-dimensional shape.
Of course, Visio has a menu to convert a 1-d shape to a 2-d shape.
But this the control frame of the converted shape is also inclined, if 1-d shape is inclined.
In order to stand the frame upright, you have to use Unnion or Joint operation.
But these operations delete all the inner data, such as shape data and user defined data.
My macro escapes it as it does not use joint nor union, but uses my mathematical rotation macro.
The converted 2-d shape has always a frame upright.
Here is a short video that explain how the macro works.
https://youtu.be/dOG0DOhB1w0
Here is one more VBA trial example.
This macro rotates all geometries in a Shape.
Also the macro to rotate geometries mathematically is used.
Here is a short video at https://youtu.be/Ir3tGIL0JMk .
Please enjoy.
Here is another trial drawing to rotate geometries in a shape.
And have a short video at
https://youtu.be/5YM4vQZMDfs .
Please, enjoy.
I am sorry my macro has some bugs, and has modified now.
And a new video at https://youtu.be/8RsD5_E1NXQ .
Please, enjoy.
I've changed my Visio into English version .
Visio pro for Office 365.
Then I revised the video now at https://youtu.be/0Jd484xf9Kk .
Please , enjoy.
I have refactored my VBA macro by a set of functions,
Function XRotate(X As Double, Y As Double, ang As Double, LocPinX As Double)
XRotate = X * Cos(ang) - Y * Sin(ang) + LocPinX
End Function
Function YRotate(X As Double, Y As Double, ang As Double, LocPinY As Double)
YRotate = X * Sin(ang) + Y * Cos(ang) + LocPinY
End Function
Now, Sin and Cos funtions dissapeared in my macro in other parts.
Is there a 64 Bit version I'm getting an error stating the scripts are fro 32 bit not 64 bit?
No, I have not.