Sketch Tool

[Thomas Winkel]

Hi,

the code below makes a sketch out of a selected diagram and vice versa, see attached screenshot.
Funny, isn't it?

BR,
Thomas

Code

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

[Paul Herber]

What fun!

[wapperdude]

Fun indeed!

I have a couple suggested changes.  The first is to add pct sign.  Otherwise there's error for that entry in shapesheet.

Code

    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.

Code

    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:

Code

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.

[wapperdude]

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

[Thomas Winkel]

Thanks for your Feedback, Wapperdude.

"20%"

Thanks, fixed in my code above.

Begin/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.

"On error resume next"

I had the same problem with some diagrams, but I used .FormulaForce
Maybe "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.

[wapperdude]

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.

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.