Hi,
the code below makes a sketch out of a selected diagram and vice versa, see attached screenshot.
Funny, isn't it?
BR,
Thomas
Public Sub sketch()
Dim shp As Visio.Shape
For Each shp In ActiveWindow.Selection
sketchRecursive shp
Next shp
End Sub
Public Sub unSketch()
Dim shp As Visio.Shape
For Each shp In ActiveWindow.Selection
unSketchRecursive shp
Next shp
End Sub
Private Sub sketchRecursive(shp As Visio.Shape)
Dim subShp As Visio.Shape
shp.Cells("SketchEnabled").Formula = True
shp.Cells("SketchLineWeight").Formula = "0.2*LineWeight"
shp.Cells("SketchAmount").Formula = 15
shp.Cells("SketchSeed").Formula = 0
shp.Cells("SketchLineChange").Formula = "20%"
shp.Characters.CharProps(visCharacterFont) = ActiveDocument.Fonts.Item("Ink Free").ID
For Each subShp In shp.Shapes
sketchRecursive subShp
Next subShp
End Sub
Private Sub unSketchRecursive(shp As Visio.Shape)
Dim subShp As Visio.Shape
shp.Cells("SketchEnabled").Formula = False
shp.Characters.CharProps(visCharacterFont) = ActiveDocument.Fonts.Item("Calibri").ID
For Each subShp In shp.Shapes
unSketchRecursive subShp
Next subShp
End Sub
What fun!
Fun indeed!
I have a couple suggested changes. The first is to add pct sign. Otherwise there's error for that entry in shapesheet.
shp.Cells("SketchLineChange").Formula = "20%"
The 2nd catches the possible situation where the 2D shape might have either a begin or end arrowhead that doesn't show because of the fill assignments. But, once sketch is set true, the arrowheads show up. So, following code corrects that situation.
If Not (shp.OneD) Then
shp.Cells("BeginArrow").Formula = 0
shp.Cells("EndArrow").Formula = 0
End If
Finally, a third suggestion is to add "On error resume next" at the beginning of the recursive routine. I found that Visio's sidebrace shape has a guarded cell and caused the code to crash.
To sum it all up, the revised code might look like this:
Private Sub sketchRecursive(shp As Visio.Shape)
Dim subShp As Visio.Shape
On Error Resume Next
shp.Cells("SketchEnabled").Formula = True
shp.Cells("SketchLineWeight").Formula = "0.2*LineWeight"
shp.Cells("SketchAmount").Formula = 15
shp.Cells("SketchSeed").Formula = 0
shp.Cells("SketchLineChange").Formula = "20%"
shp.Characters.CharProps(visCharacterFont) = ActiveDocument.Fonts.Item("Ink Free").ID
If Not (shp.OneD) Then
shp.Cells("BeginArrow").Formula = 0
shp.Cells("EndArrow").Formula = 0
shp.Cells("SketchLineChange").Formula = "20%"
End If
For Each subShp In shp.Shapes
sketchRecursive subShp
Next subShp
End Sub
Ooops, I did add a line to allow 2D shapes to have a different pct line change than 1D shapes. But, I like the 20% for both quite well.
Really cool Thomas.
BTW, reminds me of the sketchy / wacky development that Visio Guy did, and then I added some supplemental stuff. 2010, that was. Nice to see Visio finally up to speed. Reference has link to VG's development. http://visguy.com/vgforum/index.php?topic=7757.msg33035#msg33035
Thanks for your Feedback, Wapperdude.
Quote"20%"
Thanks, fixed in my code above.
QuoteBegin/EndArrow
Never seen that in my diagrams, but I was able to reproduce.
I wonder if there could be any reason, where a value <>0 is desired for a 2D shape.
Quote"On error resume next"
I had the same problem with some diagrams, but I used
.FormulaForceMaybe "On error resume next" is better for most cases.
Good idea to distinguish between 1D and 2D shapes.
I think best results would give to adapt the parameters by line length. See attached example.
QuoteNever seen that in my diagrams, but I was able to reproduce.
I wonder if there could be any reason, where a value <>0 is desired for a 2D shape.
I have a custom callout shape that has multiple geometry sections. One for the "msg body" and 3 optional lines. Because of this construction style, all lines get arrowheads. Thus, this issue becomes relevant. No idea how common it might be.