johnvisiomvp

Life with Visio and other Microsoft Toys!

VBA

This page has several VBA examples. The original source of some of these items is from messages posted on the Visio forums or the Visio CompuServe forums. There is no warranty that these are the best solutions, they just work:

This was copied from another webpage, Visio.MVPs.Org/VBA and the line breaks were lost. I am in the process of restoring the line breaks to make the code work and be readable. If the Visio.MVPs.org website still exists, you can use it to verify the code. I can not thank Karl and Felix enough for providing that website and for other MVP websites for so long at their cost.

Set Active Page: How to set the Active Page.
When you need to select shapes on a non-active page you can change the ActivePage through automation by:
ActiveWindow.Page = visDocument.Pages(iPagCtr).Name
Add Guide Line: How to add a guide line to the page.
When you need to add a horizontal guide line to a page:
hrReturn = page.AddGuide(visHorz,0,5,shpGuide)
Add Shape Numbers: This routine will process a set of files in a directory and create a new set of files that have shapes with numbers that are based on the parentage of the shape.
Sub AddShapeNumbers()
‘ Set numbers for each shape on all the pages of all the documents within a directory
‘ The changes are done in a temporary directory in case a problem arises.
Dim docsObj As Visio.Documents, docObj As Visio.Document
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim fromObj As Visio.Shape, toObj As Visio.Shape
Dim celObj1 As Visio.Cell, celObj2 As Visio.Cell, consObj As Visio.Connects
Dim conObj As Visio.Connect, conObj1 As Visio.Connect
Dim MasterIndex As Integer, i1 As Integer, i2 As Integer, i3 As Integer
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim curDocIndx As Integer, curPageIndx As Integer, curShapeIndx As Integer
Dim curConnIndx As Integer ‘ Loop variable Dim OldText As String
Dim tmpStr As String, PrevLvl As String Dim localCentx As Double
Dim localCenty As Double, localCenty1 As Double Dim LvlNum As Integer
Dim LookingForTop As Boolean Dim ShapeLoc(200) As String
Dim ShapeId(200) As Integer, ShapeIndx(200) As Integer
Dim Shape2DCnt As Integer
Dim ShapeY(200) As Double, ShapeName(200) As String, TmpY As Double
Dim ShapesCnt As Integer, ShapeLevel(200) As String
Dim SubName(200) As String, subX(200) As Integer, subCnt As Integer

‘ Set the default pathname
PathName = “C:\VisioTemp\”
PathFileName = PathName & “*.vsd”
‘ Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
Do While CurrFileName <> “”
‘ Get the number encoded in the name, the file name is drawing_nnn.vsd
i1 = InStr(1, CurrFileName, “_”, 0) – 1
tmpStr = “001”
If i1 > 0 Then
tmpStr = Left(CurrFileName, i1)
End If
LvlNum = Val(tmpStr)
‘ Open the file
PathFileName = PathName & CurrFileName
Set docObj = Documents.Open(PathFileName)
Set pagsObj = docObj.Pages
‘ iterate through the collection of pages
For curPageIndx = 1 To pagsObj.Count
‘ retrieve the page object at the current index
Set PagObj = pagsObj.Item(curPageIndx)
‘ Ignore if the current page is a background page
If PagObj.Background = False Then
Shape2DCnt = 0
Set shpsObj = PagObj.Shapes
‘ Find the top shape
ShapesCnt = shpsObj.Count
For i1 = 1 To ShapesCnt
ShapeLevel(i1) = “”
Next i1
‘ To navigate the shapes, a sort table is required to determine where on the page the shapes are
‘ The shapes are ordered from the top left to the bottom right
‘ Loop through all the shapes on the page to find their locations
For curShapeIndx = 1 To ShapesCnt
Set shpObj = shpsObj(curShapeIndx)
ShapeName(curShapeIndx) = shpObj.Name
If Not shpObj.OneD Then
Set celObj1 = shpObj.Cells(“pinx”)
Set celObj2 = shpObj.Cells(“piny”)
localCentx = 900# – celObj1.Result(“inches”) ‘ We want shapes sorted left to right
localCenty = celObj2.Result(“inches”)
Shape2DCnt = Shape2DCnt + 1
ShapeId(Shape2DCnt) = curShapeIndx
ShapeY(Shape2DCnt) = localCenty
ShapeLoc(Shape2DCnt) = Format(localCenty, “000.0000”) & Format(localCentx, “000.0000”)
End If
Next curShapeIndx
‘ Sort the shapes by location
For i1 = 1 To Shape2DCnt
For i2 = i1 + 1 To Shape2DCnt
If ShapeLoc(i1) < ShapeLoc(i2) Then
tmpStr = ShapeLoc(i1): TmpY = ShapeY(i1): i3 = ShapeId(i1)
ShapeLoc(i1) = ShapeLoc(i2): ShapeY(i1) = ShapeY(i2): ShapeId(i1) = ShapeId(i2)
ShapeLoc(i2) = tmpStr: ShapeY(i2) = TmpY: ShapeId(i2) = i3
End If
Next i2
Next i1
‘ What may appear to be a row of shapes, may be a collection of shapes with different
‘ vertical positions. To sort properly, all the shapes on a row must have the same
‘ vertical position.
If Shape2DCnt > 1 Then
For i1 = 2 To Shape2DCnt
‘ Adjust the vertical location if they are within .1
If ShapeY(i1 – 1) – ShapeY(i1) < 0.1 Then
ShapeY(i1) = ShapeY(i1 – 1)
ShapeLoc(i1) = Format(ShapeY(i1), “000.0000”) & Right(ShapeLoc(i1), 8)
End If
Next i1
End If
‘ Sort the shapes using the adjusted location
For i1 = 1 To Shape2DCnt
For i2 = i1 + 1 To Shape2DCnt
If ShapeLoc(i1) < ShapeLoc(i2) Then
tmpStr = ShapeLoc(i1): TmpY = ShapeY(i1): i3 = ShapeId(i1)
ShapeLoc(i1) = ShapeLoc(i2): ShapeY(i1) = ShapeY(i2): ShapeId(i1) = ShapeId(i2)
ShapeLoc(i2) = tmpStr: ShapeY(i2) = TmpY: ShapeId(i2) = i3
End If
Next i2
Next i1
‘ Process the list
LookingForTop = True
For MasterIndex = 1 To Shape2DCnt
‘ Search through the shapes in order, from top left to bottom right
curShapeIndx = ShapeId(MasterIndex)
Set shpObj = shpsObj(curShapeIndx)
‘ If we have not found the top shape, check if this is it.
‘ There may be unconnected shapes above the top shape so…
‘ is this the top? (Does this shape have connections?)
If LookingForTop And (shpObj.FromConnects.Count > 0) Then
ShapeLevel(MasterIndex) = CStr(LvlNum)
LookingForTop = False
End If
‘ Find the shapes connected directly below this shape
If Not LookingForTop Then
PrevLvl = ShapeLevel(MasterIndex)
subCnt = 0 ‘ Check each shape connected to this shape
For curConnIndx = 1 To shpObj.FromConnects.Count
Set conObj = shpObj.FromConnects(curConnIndx)
Set fromObj = conObj.FromSheet
For i1 = 1 To fromObj.Connects.Count
Set conObj1 = fromObj.Connects(i1)
‘ ignore the end that points to this shape
If conObj1.ToSheet.Name <> shpObj.Name Then
‘ find the object in the sorted table For i2 = 1 To Shape2DCnt
If conObj1.ToSheet.Name = ShapeName(ShapeId(i2)) Then
if MasterIndex < i2 Then
subCnt = subCnt + 1SubName(subCnt) = conObj1.ToSheet.Name
subX(subCnt) = i2
End If
End If
Next i2
End If
Next i1
Next curConnIndx
‘ Sort the sub shapes based on the sort table
For i1 = 1 To subCnt
For i2 = i1 + 1 To subCnt
If subX(i1) > subX(i2) Then
tmpStr = SubName(i1): i3 = subX(i1)
SubName(i1) = SubName(i2): subX(i1) = subX(i2)
SubName(i2) = tmpStr: subX(i2) = i3
End If
Next i2
Next i1
‘ Assign the level numbers to the subshapes
For i1 = 1 To subCnt
i3 = subX(i1)
ShapeLevel(i3) = PrevLvl & “.” & CStr(i1)
Next i1
‘ Update the shape
OldText = shpObj.Text
If ShapeLevel(MasterIndex) <> “” Then
shpObj.Text = ShapeLevel(MasterIndex) & Chr$(10) & OldText
End If
End If
Next MasterIndex
End If
Next curPageIndx
docObj.Save
docObj.Close
CurrFileName = Dir
Loop
End Sub

Assignments: These are some brief notes on assignments. (See also Result/ResultStr)
To set the formula of a cell to be a numeric do:     cellobj.Formula = “=-1”
Cellobj.Formula will now return the one character string 1.
To set the formula of a cell to be a string do:
cellobj.Formula = “=””abc”””
Cellobj.Formula will now return the five character string “abc”.
The double quotes within the string is one way to tell VB[A] to make a string with embedded quote mark characters in it. Alternatively,
cellobj.Formula = “=” & chr(34) & “abc” & chr(34)
will produce the same result.
Print Background Pages: Normally, background pages do not print with the other pages (foreground pages). This routine will print the background pages in the current document. You will have to change the PrinterName to match what is in use.
Sub PrintBackgroundPages()
Dim PagsObj As Visio.Pages
Dim PagObj As Visio.Page
Set PagsObj = ActiveDocument.Pages
‘ iterate through the collection of pages
For Each PagObj In PagsObj
ActiveWindow.Page = PagObj.Name
‘ Process if the current page is a background page
If PagObj.Background = True Then
ActiveDocument.PrintOut PrintRange:=visPrintCurrentPage, PrinterName:=”LaserJet 1012″
End If
Next PagObj
End Sub
Character List: This routine will list the individual characters that make up the text field of a shape.
Sub Char_List()
Dim shpObj As Visio.Shape
Dim ACharacters As Characters
Dim i As Integer, TextLen As Integer
Set shpObj = ActivePage.Shapes(1)
TextLen = Len(shpObj.Text)
Set ACharacters = shpObj.Characters
Debug.Print ACharacters
For i = 1 To TextLen
ACharacters.Begin = i: ACharacters.End = I
Debug.Print “Char Pos = “; i; ” Row = “;
ACharacters.CharPropsRow(visBiasLeft)
Next
End Sub
Character Manipulation: Manipulating characters in a shape. from Heidi Munson – Microsoft Corporation
Sub GetCharRows()
‘The Characters object deals with fields a bit differently than the labeling
‘in the ShapeSheet window. To analyze the text in the shape, use the .RunBegin
‘and .RunEnd properties of the Characters object. The VBA code below provides
‘a simple example of analyzing text using RunBegin and RunEnd. It expects the
‘active window to be a drawing type window and for at least one shape to be
‘selected. It analyzes the text in the first shape in the selection and finds runs
‘of Text in the shape that corresponds to each of the rows in the Characters section.
‘For simplicity work on the first shape in the selection
Dim vsoShape As Visio.Shape
Set vsoShape = ActiveWindow.Selection.Item(1)
Dim intCharCount As Integer
Dim intRunEnd As Integer
Dim intRunBegin As Integer
Dim i As Integer I = 0
Dim vsochars As Visio.Characters
‘ The initial characters object return from the Characters Property of the
‘ shape spans all the text in the shape.
‘ (warning – This may not be true if the first character of the text block is a carriage return)
Set vsochars = vsoShape.Characters
intCharCount = vsochars.CharCount
While (i + 1 < intCharCount)
‘ Set the characters object to span one character
vsochars.Begin = I
vsochars.End = I + 1
‘ Find the set of characters that
‘ share formatting with this character
intRunEnd = vsochars.RunEnd(Visio.VisRunTypes.visCharPropRow)
intRunBegin = vsochars.RunBegin(Visio.VisRunTypes.visCharPropRow)
‘ Set the characters object to span this run
vsochars.Begin = intRunBegin
vsochars.End = intRunEnd
‘ Update i so that the next time through the loop, we’ll look
‘ at the first character after this run.
I = intRunEnd
‘ Output some helpful information about this run.
Debug.Print “Row Info: Row Number = ” _
& vsochars.CharPropsRow(Visio.visBiasLeft) _
& ” CharCount ” & vsochars.CharCount
Debug.Print ” Run Begin = ” & intRunBegin _
& ” Run End ” & intRunEnd
‘ The text in this run may contain returns to make
‘ it easier to see what text belongs to each run,
‘ wrap the text in tags.
Debug.Print “<Text>” & vsochars & “</Text>”
Wend
End Sub
Circle Shape: This subroutine will drop a shape on the page and add a circle around it.
Public Sub Circle_Shape()
‘ This routine will add a circle around a shape
Dim pageObj As Visio.Page
Dim shpObj As Visio.Shape, shp1obj As Visio.Shape
Dim localCentx As Double, ShapeHeight As Double
Dim localCenty As Double, ShapeWidth As Double, ShapeRadius As Double
Dim celObj1 As Visio.Cell, celObj2 As Visio.Cell
Set pageObj = ActiveDocument.Pages.Add
pageObj.Background = False
‘ Create a rectangle
Set shp1obj = ActivePage.DrawRectangle(0, 0, 1, 1.5)
‘ Drop a copy of the rectangle
Set shpObj = ActivePage.Drop(shp1obj, 4, 5)
‘ Determine its width and height
Set celObj1 = shpObj.Cells(“Width”)
Set celObj2 = shpObj.Cells(“Height”)
ShapeWidth = celObj1.Result(“inches”)
ShapeHeight = celObj2.Result(“inches”)
If ShapeWidth > ShapeHeight Then
ShapeRadius = ShapeWidth * 1.5
Else
ShapeRadius = ShapeHeight * 1.5
End If
‘ Determine it’s pinx and piny
Set celObj1 = shpObj.Cells(“pinx”)
Set celObj2 = shpObj.Cells(“piny”)
localCentx = celObj1.Result(“inches”) – (ShapeRadius / 2)
localCenty = celObj2.Result(“inches”) – (ShapeRadius / 2)
‘ Create the circle
Set shpObj = ActivePage.DrawOval(localCentx, localCenty + ShapeRadius, localCentx + ShapeRadius, localCenty)
shpObj.Cells(“LineColor”) = 2 ‘ Colour the line Red – (Black;White;Red;Green;Blue;Yellow)
shpObj.Cells(“Fillforegnd”) = 5 ‘ Use a fill colour of Yellow
shpObj.SendToBack
End Sub
Clean Text: This subroutine will change multi-line text into single line text for display purposes.
Debug.Print “Connect —“; shpObj.Name; ” “; CleanText(shpObj.Text)
Private Function CleanText(TmpString) As String
Dim I As Integer, OldText As String
‘ Remove the carriage returns.
OldText = TmpString
I = InStr(1, OldText, Chr(10))
Do While I > 0
Mid(OldText, I) = ” ”
I = InStr(1, OldText, Chr(10))
Loop
CleanText = OldText
End Function
Colour List: List the colours in a document.
Public Sub Colour_List()
Dim PaletteEntry As Integer, vcolors As Colors Dim i1 As Integer
Dim i2 As Integer
Debug.Print “Display colours”
i1 = Visio.ActiveDocument.Colors.Count – 1
Debug.Print “number of colours “; i1 + 1
Set vcolors = Visio.ActiveDocument.Colors
For PaletteEntry = 0 To i1
Debug.Print “Palette Entry = “; PaletteEntry;
Debug.Print “R = “; vcolors(PaletteEntry).Red;
Debug.Print “B = “; vcolors(PaletteEntry).Blue;
Debug.Print “G = “; vcolors(PaletteEntry).Green
Next
End Sub
Colour Test: This subroutine will display the colours associated with shape “Sheet.13”
Public Sub TestColour()
Dim shShape As Visio.Shape, PaletteEntry As Integer, vcolors As Colors
Set shShape = Visio.ActivePage.Shapes.Item(“Sheet.13”)
Debug.Print “Display colours”
PaletteEntry = shShape.Cells(“LineColor”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print ” Line Colour Palette Entry = “; PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
PaletteEntry = shShape.Cells(“FillForegnd”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print “Foreground Colour Palette Entry = “; PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
PaletteEntry = shShape.Cells(“Fillbkgnd”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print “Background Colour Palette Entry = “; PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
End Sub
Colour Test1: This subroutine will display and change the line colour and the fill foreground colour of all the shapes on the current page.
Public Sub Colour_Test1()
Dim objshape As Visio.Shape
Dim i1 As Integer
For i1 = 1 To Visio.ActivePage.Shapes.Count
Set objshape = Visio.ActivePage.Shapes(i1)
Debug.Print objshape.Name; ” “; objshape.Cells(“linecolor”)
objshape.Cells(“LineColor”) = 5
Debug.Print objshape.Name; ” “; objshape.Cells(“linecolor”)
Debug.Print objshape.Name; ” “; objshape.Cells(“Fillforegnd”)
objshape.Cells(“Fillforegnd”) = 4
Debug.Print objshape.Name; ” “; objshape.Cells(“Fillforegnd”)
Next
End Sub
Colour Test2: This subroutine will display and change the R, G, B values for all the shapes on the current page.
Public Sub Colour_Test2()
Dim shShape As Visio.Shape, PaletteEntry As Integer, vcolors As Colors
Dim i1 As Integer
Debug.Print Visio.ActivePage.Shapes.Count
For i1 = 1 To Visio.ActivePage.Shapes.Count
Set shShape = Visio.ActivePage.Shapes(i1)
Debug.Print shShape.Name
Debug.Print “Display colours”
PaletteEntry = shShape.Cells(“LineColor”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print ” Line Colour Palette Entry = “; PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
PaletteEntry = shShape.Cells(“FillForegnd”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print “Foreground Colour Palette Entry = “;PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
PaletteEntry = shShape.Cells(“Fillbkgnd”)
Set vcolors = Visio.ActiveDocument.Colors
Debug.Print “Background Colour Palette Entry = “; PaletteEntry,
Debug.Print “R = “; vcolors(PaletteEntry).Red,
Debug.Print “B = “; vcolors(PaletteEntry).Blue,
Debug.Print “G = “; vcolors(PaletteEntry).Green
Next
End Sub
Connection Points: This subroutine will display the connection point for a page.
Public Sub ConnectionPoints()
Dim shpObj As Visio.Shape
Dim i As Integer, ShpNo As Integer
Dim PosX As Double, PosY As Double
Dim ShapeX As Double, ShapeY As Double
Debug.Print Visio.ActivePage.Shapes.Count
For ShpNo = 1 To Visio.ActivePage.Shapes.Count
Set shpObj = Visio.ActivePage.Shapes(ShpNo)
nrows = shpObj.RowCount(Visio.visSectionConnectionPts)
Debug.Print “#”; ShpNo; ” “; shpObj.Name; ” connections =”; nrows
If nrows > 0 Then
ShapeX = shpObj.CellsSRC(Visio.visSectionObject, visRowXFormOut, _
visXFormPinX).Result(Visio.visNone)
ShapeX = ShapeX – shpObj.CellsSRC(Visio.visSectionObject, visRowXFormOut, _
visXFormLocPinX).Result(Visio.visNone)
ShapeY = shpObj.CellsSRC(Visio.visSectionObject, visRowXFormOut, _
visXFormPinY).Result(Visio.visNone)
ShapeY = ShapeY – shpObj.CellsSRC(Visio.visSectionObject, visRowXFormOut, _
visXFormLocPinY).Result(Visio.visNone)
For i = 0 To nrows – 1
PosX = ShapeX + shpObj.CellsSRC(Visio.visSectionConnectionPts, i, _ visX).Result(Visio.visNone)
PosY = ShapeY + shpObj.CellsSRC(Visio.visSectionConnectionPts, i, _ visY).Result(Visio.visNone)
Debug.Print PosX; ” “; PosY Next I
End If
Next ShpNo
End Sub
Connection: This subroutine will display the list of connections for selected shapes.
Public Sub ConnectionsList()
Dim vsoConnect As Visio.Connect
Dim vsoConnects As Visio.Connects
Dim vsoSelect As Visio.Selection
Dim vsoShape As Visio.Shape
Dim vsoShapes As Visio.Shapes
Set vsoSelect = Visio.ActiveWindow.Selection
Debug.Print vsoSelect.Count
If vsoSelect.Count > 0 Then
‘For each shape in the selection, get its connections.
For Each vsoShape In vsoSelect
Set vsoConnects = vsoShape.Connects
‘For each connection, get the shape it connects to.
For Each vsoConnect In vsoConnects
‘Print the name of the shape the
‘Connect object connects to.
Debug.Print vsoShape.Name; ” connects to “; vsoConnect.ToSheet.Name
Next vsoConnect
Set vsoConnects = vsoShape.FromConnects
‘For each connection, get the shape it connects to.
For Each vsoConnect In vsoConnects
‘Print the name of the shape the ‘Connect object connects to.
Debug.Print vsoShape.Name; ” is connected from “; vsoConnect.FromSheet.Name
Next vsoConnect
Next vsoShape
Else
MsgBox “You Must Have Something Selected”
End If
End Sub
Convert CGM to stencil: This subroutine will create stencils by looping through subdirectories of CGM files. A stencil is created in the root directory for each subdirectory.
Sub AddCGM()
‘Create a Visio stencil from a collection of CGMs in a subdirectory
‘The name of the subdirectory is used as the name of the stencil
Dim docObj As Visio.Document, mastersObj As Visio.Masters
Dim masterObj As Visio.Master
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim FullFileName As String, MastrName As String
Dim Dirs(200) As String, DirCnt As Integer, DirIndx As Integer
Dim ShapeCnt As Integer
‘ Set the default pathname – the root directory
PathName = “C:\My Documents\Visio\CGMs\”
‘ Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathName, vbDirectory)
DirCnt = 0
Do While CurrFileName <> “”
If CurrFileName <> “.” And CurrFileName <> “..” Then
‘ Use bitwise comparison to make sure CurrFileName is a directory.
If (GetAttr(PathName & CurrFileName) And vbDirectory) = vbDirectory Then          DirCnt = DirCnt + 1
Dirs(DirCnt) = CurrFileName
End If
End If
CurrFileName = Dir
Loop
For DirIndx = 1 To DirCnt
Set docObj = Documents.Add(“”)
Set mastersObj = docObj.Masters
‘ Set the default pathname
PathFileName = PathName & Dirs(DirIndx) & “\*.cgm”
‘ Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
ShapeCnt = 0
Do While CurrFileName <> “”
ShapeCnt = ShapeCnt + 1
Set masterObj = mastersObj.Add
MastrName = Left(CurrFileName, Len(CurrFileName) – 4)
masterObj.Name = MastrName
FullFileName = PathName & Dirs(DirIndx) & “\” & CurrFileName
Set shpObj = masterObj.Import(FullFileName)
CurrFileName = Dir
Loop
FullFileName = PathName & Dirs(DirIndx) & SubCode & “.vsd”
docObj.SaveAs FullFileName
docObj.Close
Next DirIndx
End Sub
Create Grid: This subroutine adds a background page to the current drawing so that a grid can be printed. Some work may be required to customize the grid spacing.
Public Sub CreateGrid()
Dim pagesObj As Visio.Pages, pageObj As Visio.Page
Dim bkpageObj As Visio.Page, oldbkpageObj As Visio.Page
Dim shapeObj As Visio.Shape, i1 As Integer, backName As String
Dim celObjPagH As Visio.Cell, celObjPagW As Visio.Cell
Dim xlen As Double, ylen As Double, ytop As Double, ytop2 As Double
Dim winObj As Visio.Window Set winObj = ActiveWindow Visio.Application.ScreenUpdating = False
‘Create the grid if there is an active page
If Not (ActivePage Is Nothing) Then
Set pageObj = Visio.Application.ActivePage
Set shapeObj = pageObj.PageSheet
Set celObjPagH = shapeObj.Cells(“PageHeight”)
Set celObjPagW = shapeObj.Cells(“PageWidth”)
Debug.Print celObjPagH.Units; ” “; celObjPagW.Units
Debug.Print pageObj.Name; ” “; celObjPagH.Result(“in.”); ” “; celObjPagW.Result(“in.”)
xlen = celObjPagW.Result(“in.”)
ylen = celObjPagH.Result(“in.”)
‘ add a background page to the collection.
Set bkpageObj = ActiveDocument.Pages.Add
bkpageObj.Background = True
bkpageObj.Name = “BackgroundGrid”
‘ Create the grid
ytop = 0
Do While ytop < ylen
ytop2 = ytop
Set shapeObj = bkpageObj.DrawLine(0, ytop, xlen, ytop)
shapeObj.Cells(“LineWeight”).Formula = “1 pt.”
shapeObj.Cells(“LinePattern”) = 1 ‘
‘ add the sub grid
‘For i1 = 1 To 9
‘ ytop2 = ytop2 + 0.1
‘If ytop2 <= ylen Then
‘ Set shapeObj = bkpageObj.DrawLine(0, ytop2, xlen, ytop2)
‘shapeObj.Cells(“LineWeight”).Formula = “.05 pt.”
‘ shapeObj.Cells(“LinePattern”) = 1
‘ End If
‘ Next i1
ytop = ytop + 1
Loop
ytop = 0
Do While ytop < xlen
ytop2 = ytop
Set shapeObj = bkpageObj.DrawLine(ytop, 0, ytop, ylen)
shapeObj.Cells(“LineWeight”).Formula = “1 pt.”
shapeObj.Cells(“LinePattern”) = 1
‘ add the sub grid ‘
For i1 = 1 To 9
‘ ytop2 = ytop2 + 0.1
‘ If ytop2 <= xlen Then
‘ Set shapeObj = bkpageObj.DrawLine(ytop2, 0, ytop2, ylen)
‘ shapeObj.Cells(“LineWeight”).Formula = “.05 pt.”
‘ shapeObj.Cells(“LinePattern”) = 1
‘ End If
‘ Next i1
ytop = ytop + 1
Loop
‘ obtain the background page for this foreground page
Set oldbkpageObj = pageObj.BackPage
‘If there is a background page, attach it to the background Grid
If Not oldbkpageObj Is Nothing
Then
bkpageObj.BackPage = oldbkpageObj.Name
End If
pageObj.BackPage = bkpageObj.Name
ActiveWindow.Page = pageObj.Name winObj.Activate
End If
Visio.Application.ScreenUpdating = TrueEnd Sub
Custom Properties: This subroutine will send all of the custom properties on a page to a tab delimited text file.
Public Sub CustomProp()
Dim shpObj As Visio.Shape, celObj As Visio.Cell
Dim i As Integer, j As Integer, ShpNo As Integer
Dim LabelName As String, PromptName As String
Dim ValName As String, Tabchr As String
Open “C:\CustomProp.txt” For Output Shared As #1
Tabchr = Chr(9)
For ShpNo = 1 To Visio.ActivePage.Shapes.Count
Set shpObj = Visio.ActivePage.Shapes(ShpNo)
nRows = shpObj.RowCount(Visio.visSectionProp)
For i = 0 To nRows – 1
Set celObj = shpObj.CellsSRC(Visio.visSectionProp, i, 0)
ValName = celObj.ResultStr(Visio.visNone)
Set celObj = shpObj.CellsSRC(Visio.visSectionProp, i, 1)
PromptName = celObj.ResultStr(Visio.visNone)
Set celObj = shpObj.CellsSRC(Visio.visSectionProp, I, 2)
LabelName = celObj.ResultStr(Visio.visNone)
Debug.Print shpObj.Name, LabelName, PromptName, ValName
Print #1, shpObj.Name; Tabchr; LabelName; Tabchr; PromptName; Tabchr; ValName
Next I
Next ShpNo
Close #1
End Sub
Directory Process: A subroutine to demonstrate how to process a collection of Visio files. from John Marshall – Visio MVP
Sub ProcessDirectory()
‘ Process all the Visio drawings in the current directory
‘ Look in the current directory for Visio files and process each one by
‘ passing each page to a subroutine
‘ Remember to ignore processing this Visio file.
‘ John Marshall
Dim curDocIndx As Integer
Dim CurFileName As String
Dim curPageIndx As Integer
Dim currentDoc As String
Dim docObj As Visio.Document
Dim docsObj As Visio.Documents
Dim PagObj As Visio.Page
Dim PagsObj As Visio.Pages
Dim PathFileName As String
Dim PathName As String
currentDoc = ActiveDocument.Name  ‘ Remember the current VSD name so it can be ignored.
‘ Set the default pathname
PathName = CurDir & “\”
PathFileName = PathName & “*.vsd”
‘ Find the first file from the directory (not necessarily the first alphabetically)
CurFileName = Dir(PathFileName)
Do While CurFileName <> “”
If CurFileName <> currentDoc
Then ‘ ignore the current document
‘ Open the file
PathFileName = PathName & CurFileName
Set docObj = Documents.Open(PathFileName)
Set PagsObj = docObj.Pages
‘ iterate through the collection of pages
For curPageIndx = 1 To PagsObj.Count
‘ retrieve the page object at the current index
Set PagObj = PagsObj(curPageIndx)
‘ Ignore if the current page is a background page
If PagObj.Background = False Then
Call ProcessPage(PagObj)
Next curPageIndx ‘ Handle the next page
docObj.Close
End If ‘ Finished ignoring the current document
CurFileName = Dir ‘ Find the next Visio drawing
Loop
End Sub
Sub ProcessPage(ByRef PagObj As Visio.Page)
‘ Process a Page of an OrgChart
End Sub
Distance From: A subroutine to demonstrate a point of confusion with the DistanceFromPoint function.
Public Sub DistanceFrom()
‘ This routine will demonstrate a confusion with DistanceFromPoint
Dim pageObj As Visio.Page
Dim shpObj As Visio.Shape
Set pageObj = ActiveDocument.Pages.Add
‘ Create a rectangle
Set shpObj = ActivePage.DrawRectangle(0, 0, 1, 1)
c = shpObj.DistanceFromPoint(0#, 0#, 1)
b = shpObj.DistanceFromPoint(0#, 12#, 1)
Debug.Print “c = “; c; ” b =”; b
‘ The user’s comments:
‘ Unfortunately I sometimes get C + b < 12 which should be
‘ impossible if the point in the shape is unique. Oddly, when the
‘ offending shape is moved far enough to the right on the page
‘ the error goes away.
‘ The problem with this logic is that though the reference point is
‘ unique, the point on the shape is not always the same, it is the
‘ nearest point on the shape to the reference point.
End Sub
Document Names: This subroutine will display the name of the current document and the current page.
Public Sub DisplayDoc()
‘ Display the name of the current document and the current page
Debug.Print ActiveDocument.Name
Debug.Print ActivePage.Name
End Sub
Dropping a Master: This subroutine will drop a master on the page. You need to get a Master or Shape object to drop on the page before calling the Drop method. The example below drops the Circle shape from the Blocks Raised stencil on the current drawing page.
Public Sub TestDropShape()
Dim stencil As Visio.Document, mstCircle As Visio.Master
Set stencil = ThisDocument.Application.Documents.Open(“Blocks Raised.vss”)
ThisDocument.Application.Windows(ThisDocument.Index).Activate
Set the ActiveWindow to the drawing window.
Set mstCircle = stencil.Masters(“Circle”)
‘ Get the master named “Circle” and drop that shape on the page!
ThisDocument.Pages(1).Drop mstCircle, 1, 3 ‘ Drop the shape, mstCircle, at location X=1 Y=3
End Sub
Edit Stencil: This code segment shows how to edit the shapes in a stencil.
Dim mstObj As Visio.Master, mstObjCopy As Visio.Master
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim StnObj As Visio.Document
Dim PathName As String
Dim FullFileName As String
Dim curShapeIndx As Integer
FullFileName = PathName & “test1.vss”
Set StnObj = Documents.Open(FullFileName)
For curShapeIndx = 1 To StnObj.Masters.Count
Set mstObj = StnObj.Masters(curShapeIndx)
Set mstObjCopy = mstObj.Open
Set shpsObj = mstObjCopy.Shapes
Set shpObj = shpsObj(1)
‘ do something to the shape
mstObjCopy.Close
Next curShapeIndx
StnObj.Save
StnObj.Close
Set StnObj = Nothing
End Sub
Excel Report: This is an example of creating a report in Excel.
Public Sub ExcelReport()
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim celObj1 As Visio.Cell, celObj2 As Visio.Cell
Dim curShapeIndx As Integer
Dim localCentx As Double, localCenty As Double, localCenty1 As Double
Dim ShapesCnt As Integer, i As Integer
Dim ShapeHeight As Visio.Cell, ShapeWidth As Visio.Cell
Dim XlApp As Excel.Application
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Set XlApp = CreateObject(“excel.application”)
‘ You may have to set Visible property to True if you want to see the application.
XlApp.Visible = True
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets(“sheet1”)
Set shpObjs = ActivePage.Shapes ShapesCnt = shpObjs.Count
XlSheet.Cells(1, 1) = “Indx”
XlSheet.Cells(1, 2) = “Name”
XlSheet.Cells(1, 3) = “Text”
XlSheet.Cells(1, 4) = “localCenty”
XlSheet.Cells(1, 5) = “localCentx”
XlSheet.Cells(1, 6) = “Width”
XlSheet.Cells(1, 7) = “Height”
‘ Loop through all the shapes on the page to find their locations
For curShapeIndx = 1 To ShapesCnt
Set shpObj = shpObjs(curShapeIndx)
If Not shpObj.OneD Then
Set celObj1 = shpObj.Cells(“pinx”)
Set celObj2 = shpObj.Cells(“piny”)
localCentx = celObj1.Result(“inches”)
localCenty = celObj2.Result(“inches”)
Set ShapeWidth = shpObj.Cells(“Width”)
Set ShapeHeight = shpObj.Cells(“Height”)
Debug.Print shpObj.Name, shpObj.Text, curShapeIndx; Format(localCenty, “000.0000”) & ” ” & Format(localCentx, “000.0000”); ” “; ShapeWidth; ” “; ShapeHeight
I = curShapeIndx + 1
XlSheet.Cells(i, 1) = curShapeIndx
XlSheet.Cells(i, 2) = shpObj.Name
XlSheet.Cells(i, 3) = shpObj.Text
XlSheet.Cells(i, 4) = localCenty
XlSheet.Cells(i, 5) = localCentx
XlSheet.Cells(i, 6) = ShapeWidth
XlSheet.Cells(i, 7) = ShapeHeight
End If
Next curShapeIndx ‘
Set shpObj = ActivePage.DrawOval(1.5, 10.5, 7.5, 6.5) ‘left top right bottom
XlApp.Quit ‘ When you finish, use the Quit method to close
Set XlApp = Nothing ‘
End Sub
Export pages: These are examples of how to export pages in various formats.
Sub ExportHTML()
Dim pageObj As Visio.Page
Dim filename As String
Set pageObj = ThisDocument.Pages.Item(“page-1”)
filename = “c:\tmpHTML.html”
pageObj.Export  filename
or
pageObj.Export (“C:\temp\temp.jpg”)
End Sub
… and from Graham Wideman
This particular example cranks through all the pages in a single Visio file, and outputs GIF and WMF versions, using the visio file’s directory as the location, and the page name as the base file name.
Set Pgs = Application.ActiveDocument.Pages
For N = 1 To Pgs.Count
Set Pg = Pgs(N)
PgName = Pg.Name
ExportName = Application.ActiveDocument.Path + PgName + “.GIF”
Pg.Export ExportName
ExportName = Application.ActiveDocument.Path + PgName + “.WMF”
Pg.Export ExportName
Next N
Font change: This code will change all the text in all the shapes to 12pt.
Public Sub FontChange()
‘ Change the font of all shapes to 12pt
Dim shpObjs As Visio.Shapes, shpObj As Visio.Shape
Dim i As Integer
Set shpObjs = ActivePage.Shapes
For i = 1 To shpObjs.Count
Set shpObj = shpObjs(i)
Set celObj = shpObj.Cells(“Char.Size”)
celObj.Formula = “=12 pt.”
‘ or
‘ shapeObj.Cells(“Char.Size[1] “).Formula = “= 12 pt.”
Next
End Sub
Font List: This code will list the id of a specific font by name and then list all the fonts available to the current document.
Public Sub FontList()
‘ List the fonts in the current document
Dim shpObjs As Visio.Shapes, FntObjs As Visio.Fonts
Dim i As Integer
Set FntObjs = ActiveDocument.Fonts
Debug.Print FntObjs.Item(“Batang”).ID
For i = 1 To FntObjs.Count
Debug.Print FntObjs(i).Name; ” “; FntObjs(i).ID; ” “; FntObjs(i).Index
Next
End Sub
FormatResult: These are examples of using FormatResult from Mike Frederick of Visio
FormatResult takes a number or string and produces a formatted string. The example below demonstrates this:
‘ This uses FormatResult to convert a number expressing a distance in a know measurement system to a formatted string.
‘ It then uses ConvertResult to convert the string back into a number.
Public Sub num2str2num()
‘ Convert 13.5 feet into string of form f’i”.
Dim dblFeet As Double: feet = 13.5
‘ Convert the number to a formatted string.
Dim strFtIn1 As String
strFtIn1 = Application.FormatResult(13.5, visFeet, visFeetAndInches, “##\’ ##\”””)
Debug.Print strFtIn1 ‘ Reports 13 ‘ 6″. The extra space is erroneous on Visio’s part.
Dim strFtIn2 As String strFtIn2 = Application.FormatResult(13.5, visFeet, visFeetAndInches, “##””ft.”” ##””in.”””)
Debug.Print strFtIn2 ‘ Reports 13 ft. 6in.
‘ Convert the number to a formatted string in different units.
Dim strCM As String strCM = Application.FormatResult(13.5, visFeet, visCentimeters, “##”” cm.”””)
Debug.Print strCM ‘ Reports 411 cm. ‘ Now convert the string values back to numbers. ‘ Note: We only kept two digits in conversion so round trip likely not exact.
dblFeet = Application.ConvertResult(strFtIn1, visFeetAndInches, visNoCast)
Debug.Print dblFeet ‘ Reports 13.5 dblFeet = Application.ConvertResult(strFtIn2, visFeetAndInches, visNoCast)
Debug.Print dblFeet ‘ Reports 13.5 dblFeet = Application.ConvertResult(strCM, visCentimeters, visFeet)
Debug.Print dblFeet ‘ Reports 13.4842519685039
End Sub
GetFormulas vs CellsSRC: from Rob Fahrni of Visio
I did a little testing and found that GetFormulas was two to three times faster than CellsSRC, your mileage may vary. 🙂

Here’s the little sample I ran. This code doesn’t do anything with the results, it simply queries the shapes for formulas in two different ways.

Private Sub useCellsSRC(pg As Visio.Page)
Dim shp As Visio.Shape
Dim shps As Visio.Shapes
Dim cell As Visio.cell
Dim cnt As Integer
Dim idx As Integer
Dim rowCnt As Integer
Dim strOut As String
rowCnt = 0
Set shps = pg.Shapes

Dim startTime As Date
startTime = Time

For idx = 1 To shps.Count
Set shp = shps(idx)

If (Not shp Is Nothing) Then
If (shp.SectionExists(visSectionProp, False) = True) Then
rowCnt = rowCnt + shp.RowCount(visSectionProp)
For cnt = 1 To shp.RowCount(visSectionProp)
Set cell = shp.CellsSRC(visSectionProp, cnt, visCustPropsValue)

If (Not cell Is Nothing) Then
strOut = cell.Formula
End If
Next

End If
End If
Next

Debug.Print “——————————- CellsSRC”
Debug.Print “Total Shapes: ” & shps.Count
Debug.Print “Total Rows : ” & rowCnt
Debug.Print “Total Time : ” & Format(Time – startTime, “hh:mm:ss”)
Set shp = Nothing
Set shps = Nothing
Set cell = Nothing End Sub

Private Sub useGetFormulas(pg As Visio.Page)
Dim shp As Visio.Shape
Dim shps As Visio.Shapes
Dim cell As Visio.cell
Dim cnt As Integer
Dim idx As Integer
Dim rowCnt As Integer
Dim realRow As Integer
Dim formArray() As Variant

rowCnt = 0 Set shps = pg.Shapes

Dim startTime As Date startTime = Time

For idx = 1 To shps.Count Set shp = shps(idx)

If (Not shp Is Nothing) Then
If (shp.SectionExists(visSectionProp, False) = True) Then
rowCnt = rowCnt + shp.RowCount(visSectionProp)
‘ Fill the array ‘
ReDim srcArray(1 To shp.RowCount(visSectionProp) * 3) As Integer
realRow = 0
For cnt = LBound(srcArray) To UBound(srcArray) Step 3
srcArray(cnt) = visSectionProp
srcArray(cnt + 1) = realRow
srcArray(cnt + 2) = visCustPropsValue
realRow = realRow + 1
Next

Call shp.GetFormulas(srcArray, formArray) End If

End If

Next

Debug.Print “——————————- GetFormulas”
Debug.Print “Total Shapes: ” & shps.Count
Debug.Print “Total Rows : ” & rowCnt
Debug.Print “Total Time : ” & Format(Time – startTime, “hh:mm:ss”)

Set shp = Nothing
Set shps = Nothing
Set cell = Nothing
End Sub

Here are the results from my last run…
——————————- CellsSRC
Total Shapes: 938
Total Rows : 2814
Total Time : 00:00:09

——————————- GetFormulas
Total Shapes: 938
Total Rows : 2814
Total Time : 00:00:03

Graduated fill colors: from Mike Frederick Visio
You can set the fill pattern of a shape to create a graduated fill. For example, pick a rectangle then open the Format Fill dialog. Drop down the fill pattern list box. At the end of the list you’ll see several patterns that will cause the shape to adopt a fill pattern that gradually changes color from one extreme of its extents to the other. The color will gradually change from the shape’s fill foreground color to its fill background color.
The same effect can be achieved with VBA by setting the appropriate cells in the shape’s fill properties section. The snippet below will set the fill of shpObj such that it is green at its extremities and gradually more red toward its interior:
shpObj.Cells(“FillPattern”) = 35 ‘ Set fill pattern to one of available graduated fill patterns.
shpObj.Cells(“FillForegnd”) = 2 ‘ Set fill foreground color to red.
shpObj.Cells(“FillBkgnd”) = 3 ‘ Set fill background color to green.
Handling older versions of Visio: from Chris Roth Visio – Visio MVP
I created my VBA code in a Visio 2002 and later realized I used some properties that don’t exist in Visio 2000, but which I’d like to keep using for users with 2002. Is there a way to get this to pass through without being checked unless the Visio version supports it?
There are conditional compilation statements in VBA:
‘ Comment out the appropriate line…
‘#Const Vis2002 = True
#Const Vis2003 = True
Sub Bob()
#If Vis2002 Then
Debug.Print “Visio 2002!”
#End If
#If Vis2003 Then
Debug.Print “Visio 2003!”
#End If
End Sub
But you have to set them before you distribute. You can also do late binding, where you just use generic objects when making calls that “might not be there.” VBA won’t gack on the first block, because it doesn’t check to see if obj has a method called “DoSomethingOnly2003Does” until the very last second, so to speak:
If Visio.Application.Version = “11.0” then
Dim obj as Object
Set obj = Visio.Application
obj.DoSomethingOnly2003Does
Else
‘ Do something else for older versions
End if
Header Footer: This program sets values for the header and footer.
Public Sub HeaderFooter()
Dim OldText As String
Dim szFooter As String
OldText = “This is a test to set the title”
ThisDocument.HeaderCenter = “Document Title” & OldText
‘Build footer string
szFooter = “Page &p of &P”
‘Set footer of current document
ThisDocument.FooterCenter = szFooter
End Sub
Hiding Master Shapes: To disable masters on a stencil. from Dave Parker – Visio MVP
I would like to disable one or more masters on a stencil depending on user selection in the drawing page. Could I disable masters?
You can make them Hidden in code, eg
ThisDocument.Masters(“MyMaster”).Hidden = TRUE
Hiding Other Object: How do you hide the ruler, grid, guides and connection points? from Mark Nelson Microsoft
Application.ActiveWindow.ShowRulers = False
Application.ActiveWindow.ShowGrid = False
Application.ActiveWindow.ShowGuides = False Application.ActiveWindow.ShowConnectPoints = False
Hiding Warning Dialogs: To suppress warning dialogs try…
You can use the AlertResponse property of the application to tell Visio what the default response to a message box should be. So basically you can “turn” off the message. E.G…
Dim oldResponse as Integer
oldResponse = app.AlertResponse
app.AlertResponse = 1 ‘ This is like clicking on Ok
selection.Ungroup ‘ Ungroup the selection.
app.AlertResponse = oldResponse ‘ Restore OLD AlertResponse.
This should keep the dialog from being displayed.
Other values for AlertResponse are:
1 – OK
2 – CANCEL
3 – ABORT
4 – RETRY
5 – IGNORE
6 – YES
7 – NO
(See Microsoft knowledge base article Q279710)
Hiding Visio: from Dan Westford Visio Developer Support Supervisor
The API calls shown below seems to effectively hide Visio. Const
SW_HIDE = 0 ‘
Const SW_MAXIMIZE = 3
Const SW_MINIMIZE = 6
Const SW_RESTORE = 9
Private Declare Function ShowWindow Lib “user32” (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetParent Lib “user32” (ByVal hwnd As Long) As Long Public Sub HideWindow()
Dim hwnd As Long
hwnd = Application.WindowHandle32
ShowWindow hwnd, SW_HIDE
End Sub
HitTest Example: from Mark Nelson Visio Technical Solutions
Making shapes aware of their neighbours is indeed powerful functionality, but implementing this can take some work. There are two ways of detecting shape proximity. First, if one shape is glued to another, you can get the ConnectionsAdded event to tell you about the connection. Second, you can manually check shape relationships with the HitTest method or by comparing geometry.
HitTest will tell you whether a point in space is inside a shape, outside a shape or on the perimeter of a shape. You can also specify a tolerance to define a circular area to be used when checking. Using the example of dropping a valve on a pipeline, we want to run the HitTest on the pipeline. The size of the valve defines the tolerance to be used.
‘Get information about valve shape
dCenterX = ValveShape.Cells(“PinX”).ResultIU
dCenterY = ValveShape.Cells(“PinY”).ResultIU
dHalfWidth = ValveShape.Cells(“Width”).ResultIU / 2
dHalfHeight = ValveShape.Cells(“Height”).ResultIU / 2
If dHalfWidth > dHalfHeight Then
dTolerance = dHalfWidth
Else
dTolerance = dHalfHeight
End If
Perform HitTest on pipeline shape
If PipelineShape.HitTest(dCenterX, dCenterY, dTolerance) = visHitOnBoundary Then
MsgBox “Shapes are close.”
Else
MsgBox “Shapes are not close.”
End If
Layer – Listing Shapes: This routine will list all the shapes on each layer on each page of the current document.
Public Sub LayersContent()
Dim PagObj As Visio.Page
Dim layersObj As Visio.Layers, layerObj As Visio.Layer
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
For Each PagObj In ActiveDocument.Pages
Set layersObj = PagObj.Layers
For Each layerObj In layersObj
Set shpsObj = layerObj.Page.Shapes
For Each shpObj In shpsObj
Debug.Print layerObj.Name; ” “; shpObj.Name
Next
Next
Next
End Sub
Layer – Listing Shapes: A slight modification as suggested. from YODA Junichi (aka junethesecond)
Public Sub LayersContent2()
Dim PagObj As Visio.Page
Dim layersObj As Visio.Layers, layerObj As Visio.Layer
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim I As Long, N As Long
For Each PagObj In ActiveDocument.Pages
For Each shpObj In PagObj.Shapes
N = shpObj.LayerCount
If N > 0 Then
For I = 1 To N
Set layerObj = shpObj.Layer(I)
Debug.Print PagObj.Name; ”  “; shpObj.Name; ”  “;layerObj.Name
Next I
End If
Next ShpObj
Next PagObj
End Sub
Layer – Adding Shapes: This sample VBA procedure will take all of the selected shapes and move them to a layer called “Shapes”. from Chris Hopkins Developer Support Engineer Visio Corporation
Public Sub MoveToLayer()

Dim objShps As Visio.Selection, objShp As Visio.Shape
Dim objLayers As Visio.Layers, objLayer As Visio.Layer
Dim i As Integer

‘get the Selection
Set objShps = Visio.ActiveWindow.Selection

‘get the layers collection
Set objLayers = Visio.ActivePage.Layers
Set objLayer = objLayers(“Shapes”)

For i = 1 To objShps.Count
Set objShp = objShps(i)
objLayer.Add objShp, 0
Next I

End Sub

Layer – Hiding: This sample VBA code will hide specific layers. from Graham Wideman Visio MVP
First, master it manually:
– Create a page and add a couple of layers using the Layers button or View Layer Prop
– Drop a couple of shapes and set them to be members of particular layers.
– Open up Page’s SHapeSheet, and note the Layers section. Try switching the Visible cells to 1 or 0.
Now you can do same operation in code, for example, to set the second layer to not visible:
Set APage = ActivePage
Set ACell = APage.PageSheet.Cells(“Layers.Visible[2]”)
ACell.Formula = “=0”
Location Table: This routine will create a text file listing the size and location of all 2-d shapes on the current page.
Public Sub LocationTable()
‘This routine will create a text file of the location and size of all 2-d shapes
‘ on the current page
Dim shpObj As Visio.Shape, celObj As Visio.Cell
Dim ShpNo As Integer, Tabchr As String, localCent As Double
Dim LocationX As String, LocationY As String
Dim ShapeWidth As String, ShapeHeight As String
Open “C:\LocationTable.txt” For Output Shared As #1
Tabchr = Chr(9)
For ShpNo = 1 To Visio.ActivePage.Shapes.Count
Set shpObj = Visio.ActivePage.Shapes(ShpNo)
If Not shpObj.OneD Then
‘ Only list the 2-D shapes
Set celObj = shpObj.Cells(“pinx”) localCent = celObj.Result(“inches”)
LocationX = Format(localCent, “000.0000”)
Set celObj = shpObj.Cells(“piny”)
localCent = celObj.Result(“inches”)
LocationY = Format(localCent, “000.0000”)
Set celObj = shpObj.Cells(“width”)
localCent = celObj.Result(“inches”)
ShapeWidth = Format(localCent, “000.0000”)
Set celObj = shpObj.Cells(“height”)
localCent = celObj.Result(“inches”)
ShapeHeight = Format(localCent, “000.0000”)
Debug.Print shpObj.Name, CleanText(shpObj.Text), LocationX, LocationY, ShapeWidth, ShapeHeight
Print #1, shpObj.Name; Tabchr; CleanText(shpObj.Text); Tabchr; LocationX; Tabchr; LocationY; Tabchr; ShapeWidth; Tabchr; ShapeHeight
End If
Next ShpNo
Close #1
End Sub
Lock Group: This program demonstrates locking of groups.
Public Sub LockGroup()
Dim shpObj As Visio.Shape, celObj As Visio.Cell
Dim ShpNo As Integer
Dim LockGroup As Integer
Debug.Print Visio.ActivePage.Shapes.Count
For ShpNo = 1 To Visio.ActivePage.Shapes.Count
Set shpObj = Visio.ActivePage.Shapes(ShpNo)
Set celObj = shpObj.CellsSRC(Visio.visSectionObject, visRowLock, visLockGroup)
celObj.Formula = 1
LockGroup = shpObj.CellsSRC(Visio.visSectionObject, visRowLock, visLockGroup).Result(Visio.visNone)
Debug.Print shpObj.Name; ” “; LockGroup
Next ShpNo
End Sub
LoopThroughFiles: This subroutine loops through the files in a specific directory.
Sub LoopThroughFiles()
‘ This program will loop through specific files within a directory.
Dim docsObj As Visio.Documents, docObj As Visio.Document, pagsObj as Visio.Pages
Dim PathFileName As String, PathName As String, CurrFileName As String
‘ Set the default pathname
PathName = “C:\VisioTemp\”
PathFileName = PathName & “*.vsd”
‘ Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
Do While CurrFileName <> “”
‘ Open the file
PathFileName = PathName & CurrFileName
Set docObj = Documents.Open(PathFileName)
Set pagsObj = docObj.Pages
‘ Do what you want to the pages in this file!
docObj.Save
docObj.Close
CurrFileName = Dir
Loop
End Sub
Margins: This subroutine loops through the selected shapes and increases the top margin. from John Marshall – Visio MVP
Sub AdjustTopMargin()
Dim vsoShape As Visio.Shape, vsoSelection As Visio.Selection, vsoShapeMargin As Double
Set vsoSelect = Visio.ActiveWindow.Selection
if vsoSelect.Count>0 Then
For Each vsoShape in vsoSelect
vsoShapeMargin = vsoShape.CellsSRC
(visSelectionObject,visRowText,visTxtBlkTopMargin).Result(“inches”)
vsoShape.CellsSRC(visSectionObject,visRowText,visTxtBlkMargin) _
=vsoShapeMargin+0.1
Next vsoShape
End Sub
Menus: Add Items to the File menu.
Public Sub MenuItem_Add()
Dim uiObj As Visio.UIObject
Dim visMenuSets As Visio.MenuSets
Dim visMenuSet As Visio.MenuSet
Dim visMenus As Visio.Menus
Dim visMenu As Visio.Menu
Dim visMenuItems As Visio.MenuItems
Dim visMenuItem As Visio.MenuItem
Set uiObj = Visio.Application.BuiltInMenus
Set visMenuSets = uiObj.MenuSets
‘ Get the Visio object context menu set.
Set visMenuSet = visMenuSets.ItemAtID(visUIObjSetDrawing)
Set visMenus = visMenuSet.Menus
‘ Get the file menu from the menus collection.
Set visMenu = visMenus.Item(0)
‘ Get the items collection from the file menu
Set visMenuItems = visMenu.MenuItems
‘ Add Example Menu Item to the File menu in the 4th position
Set visMenuItem = visMenuItems.AddAt(3) visMenuItem.Caption = “Example”
visMenuItem.State = Visio.visButtonUp
‘ Have Example run the HelloWorld Sub procedure
visMenuItem.AddOnName = “ThisDocument.HelloWorld” ‘
Set the new menus.
Visio.Application.SetCustomMenus uiObj
‘ Tell Visio to use the new UI when the document is active. ThisDocument.SetCustomMenus uiObj
End Sub
Menus:Removing Items from the context menus… from Chris Hopkins Developer Support Engineer Visio Corporation
Here is a bit of VBA sample code that removes Cut, Copy and Paste from the object selection context menu…

Public Sub EditMenu()

Dim visUIObj As Visio.UIObject
Dim visMenuSets As Visio.MenuSets, visMenuSet As Visio.MenuSet
Dim visMenus As Visio.Menus, visMenu As Visio.Menu
Dim visMenuItems As Visio.MenuItems, visMenuItem As Visio.MenuItem

Set visUIObj = Visio.Application.BuiltInMenus
Set visMenuSets = visUIObj.MenuSets

‘get the contextmenu set for object selection
Set visMenuSet = visMenuSets.ItemAtID(visUIObjSetCntx_DrawObjSel)
Set visMenus = visMenuSet.Menus
Set visMenu = visMenus(0)
Set visMenuItems = visMenu.MenuItems

‘remove the Cut, Copy and Paste items
visMenuItems(2).Delete
visMenuItems(1).Delete
visMenuItems(0).Delete

‘Set the menu modifications
Visio.Application.SetCustomMenus visUIObj

End Sub

Page Names: This routine will display the names of all the pages in a document along with the name of the previous page and the next page.
Public Sub PageNames()
‘ List the names of the pages in the current doc
Dim PagObj As Visio.Page
Dim indx As Integer, PrevPage As String, NextPage As String
For Each PagObj In ActiveDocument.Pages
indx = PagObj.Index: NextPage = “–none–“: PrevPage = “–none–”
If indx > 1 Then
PrevPage = ActiveDocument.Pages(indx – 1).Name
End If
If indx < ActiveDocument.Pages.Count Then
If ActiveDocument.Pages(indx + 1).Background = False Then
NextPage = ActiveDocument.Pages(indx + 1).Name
End If
End If
Debug.Print PagObj.Index; ” “; PagObj.Name; ” Prev Page =”; PrevPage; ” Next Page =”; NextPage
Next
End Sub
Page Order: This code will change the order of a page.
To put the third page in front of the second page.
Activedocument.Pages.Item(3).Index = 2
Page Size: This routine will change the size of the current page.
Public Sub PageSize()
‘ This routine will change the paper size
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageWidth”)
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageHeight”)
ActivePage.Shapes(“thePage”).Cells(“PageWidth”).Formula = 7.5
ActivePage.Shapes(“thePage”).Cells(“PageHeight”).Formula = 15
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageWidth”)
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageHeight”)
ActivePage.Shapes(“thePage”).Cells(“PageWidth”).Formula = 8.5
ActivePage.Shapes(“thePage”).Cells(“PageHeight”).Formula = 11
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageWidth”)
Debug.Print ActivePage.Shapes(“thePage”).Cells(“PageHeight”)
End Sub
Polar Array: This routine will distribute a shape in a circular pattern. The distributed shapes are rotated about the centre of the circle. from Chris Roth – Visio MVP
Sub PolarArray()
‘ by Chris Roth
Dim shp As Visio.Shape, shpObj As Visio.Shape, celObj As Visio.Cell
Dim iNum As Integer, i As Integer
Dim dRad As Double, dAngStart As Double, dAng As Double
Dim x As Double, y As Double
‘ obtain the shape to be distributed
Set shp = Visio.ActiveWindow.Selection(1)
Const PI = 3.14159265358
iNum = InputBox(“Enter the number of items in the array:”, “Polar Array”)
dRad = InputBox(“Enter the radius for the polar array in inches:”, “Polar Array”)
dAngStart = InputBox(“Enter the first angle in degrees (0 deg = 3 o’clock):”, “Polar Array”)
dAngStart = dAngStart * PI / 180 ‘Convert to radians
dAng = 2 * PI / iNum
For i = 1 To iNum
x = dRad * Cos(dAngStart + dAng * (i – 1)) + 4.25
y = dRad * Sin(dAngStart + dAng * (i – 1)) + 5.5
Set shpObj = Visio.ActivePage.Drop(shp, x, y)
shpObj.Text = I
‘ rotate the shape
Set celObj = shpObj.Cells(“Angle”)
celObj.Formula = Str(Int((i – 1) * 360 / iNum)) + “deg.”
Next I
End Sub
ProcessOpenDocuments: Loop through the open documents and process the pages.
Sub ProcessOpenDocuments()
‘ Loop through the current document collection
Dim docsObj As Visio.Documents, docObj As Visio.Document
Dim curDocIndx As Integer, curPageIndx As Integer ‘ Loop variables
Dim strDocName As String
‘Get the Visio Documents collection
Set docsObj = Documents
‘ Loop throught the documents collection
For curDocIndx = 1 To docsObj.Count
Get the ith document from the Documents collection
Set docObj = docsObj.Item(curDocIndx)
‘ Get the Document Name property
strDocName = docObj.Name
If UCase(Right(strDocName, 3)) = “VSS” Then
‘ Process the stencil
else
‘ Process the pages
Set pagsObj = docObj.Pages
‘ iterate through the collection
For curPageIndx = 1 To pagsObj.Count
‘ retrieve the page object at the current index
Set pagObj = pagsObj.Item(curPageIndx)
‘ Check whether the current page is a background page
‘ Display the name of all the foreground pages
If pagObj.Background = False Then
‘ Process the page
Else
‘ Process the background page
‘ or delete this section to ignore the background pages
End If
Next curPage
Indx docObj.Save
docObj.Close
End If
Next
curDocIndx
End Sub
Read Text: This subroutine show how to create a Visio drawing from a text files.
Public Sub Read_Text()

Dim DocObj As Visio.Document, mstObj As Visio.Master
Dim pagesObj As Visio.Pages, pageObj As Visio.Page
Dim shpObj As Visio.Shape, shp1obj As Visio.Shape
Dim stnObj As Visio.Document, celObj As Visio.Cell
Dim TextLine As String, Field1 As String, Field2 As String, Field3 As String
Dim i As Integer, j As Integer
Dim ix As Double, iy As Double, maxix As Double
Dim ih As Double, iw As Double
Visio.Application.ScreenUpdating = False
ix = 0: iy = 0: ih = 0.3: iw = 4
Set pagesObj = ActiveDocument.Pages
Set pageObj = pagesObj.Add
pageObj.Background = False
Set shp1obj = ActivePage.DrawRectangle(0, 0, iw, ih * 2)
Set celObj = shp1obj.Cells(“Char.Size”) celObj.Formula = “=8 pt.”
Open “C:\My Documents\Testfields.txt” For Input As #1
Do While Not EOF(1) ‘ Loop until end of file.
Line Input #1, TextLine ‘ Read line into variable.
Field1 = Trim(Mid(TextLine, 1, 10))
Field2 = Trim(Mid(TextLine, 11, 20))
Field3 = Trim(Mid(TextLine, 21, 30))
iy = iy + iw + 0.5
ix = 0
Set shpObj = ActivePage.Drop(shp1obj, iy, ix)
shpObj.Text = Field1 & ” ” & Field2 & ” ” & Field3
ix = ix – (ih * 2)
If ix < maxix Then maxix = ix
ix = ix – (ih * 2)
Loop
Close #1
shp1obj.Delete
ActivePage.Shapes(“thePage”).Cells(“PageWidth”).Formula = Int(iy + 0.5) + 1
ActivePage.Shapes(“thePage”).Cells(“PageHeight”).Formula = Int(-maxix + 0.5) + 1
ActivePage.CenterDrawing
Visio.Application.ScreenUpdating = True
End Sub

Result/ResultStr: These are notes on the Result and ResultStr properties. from Mike Frederik, Visio
Host = ActivePage.Shapes(i).Cells(“Prop.HostName”).ResultStr(0)
The ResultStr property is the similar to a cell’s Result property. The difference is that ResultStr returns a string for the value of the cell, whereas Result returns a floating point number.
The argument designate the units of measure you want the result expressed in. For cells whose formula does evaluate to a string, any value can be given, but in some cases you may want the value of the cell with a numeric value expressed as a string. You may want, for example, to populate a list box with “1 in.” or “2.54 cm” based on language settings. In such a case, you’d designate which you want by passing visInches or visCentimeters to ResultStr.
Using ResultStr is slightly different than using Formula. Formula literally returns the cell’s formula, whereas ResulStr returns the cell’s result expressed as a string.
Suppose the cell’s formula is simply “=abc”. Then
cell.Formula returns “abc” (quote marks included)
cell.ResultStr(0) returns abc (quote marks not included)
The difference is more significant when the formula is more than a string constant. Suppose the formula is a concatenation: = “string1″&”string2”      cell.Formula returns “string1″&string2”
cell.ResultStr(0) returns string1string2 You can ask a cell to report its value as either a number or a string.
If the value is a number then:
numvar = cellobj.ResulIU ‘ assigns the result as a number to numvar
strvar = cellobj.ResultStr(unitscode) ‘ assigns the result in string form to strvar
If the value is a string then:
numvar = cellobj.ResulIU ‘ assigns 0 to numvar
strvar = cellobj.ResultStr(unitscode) ‘ assigns the result in string form to strvar
Rotating using VBA: This routine sets the angle of the shape.
You use the Angle cell to rotate a shape, and use a statement such as objShape.Cells(“Angle”) = The catch is that the default units of it is radians. And x degrees = x*PI/180 radians. Thus, to rotate a shape through 45 deg, use a statement such as: objShape.Cells(“Angle”) = 45 * 3.1416 / 180
Or you could use the Formula property to get or set a formula in the Angle cell.
Set objShape = Visio.Application.ActiveWindow.Selection(1)
objShape.Cells(“Angle”).Formula = “-180 deg.”
Runaddon: from Mike Frederik, Visio
A simple way to open a document when a shape is double clicked on is to set the formula of its EventDblClick cell to something like this:
=RUNADDON(“documents.open “”c:\temp\junk.vsd”””)
Double clicking on the shape will open the named file. If you don’t want to hard wire the name of the file in the formula you can store the file name in a user or scratch cell and use something like:
=RUNADDON(“documents.open “&User.Row_1)
where User.Row_1.Value might be:
=”””c:\temp\junk.vsd”””
These examples are using a trick whereby we’re using a string of code that VBA can execute as the operand to the RUNADDON function. It turns out that Visio supplies a function specifically for opening a file:
=OPENFILE(“c:\temp\junk.vsd”)
Yet another option is to use the GOTOPAGE function which is overloaded to be able to navigate to named documents:
=GOTOPAGE(“c:\temp\junk.vsd”)
or even to arbitrary urls:
>=GOTOPAGE(“http://www.visio.com/&#8221;)
Of course you can make the shape into a hyperlink also, instead of or in addition to setting its EventDblClick cell. That may be very useful in your application.
Save as Dialog: This routine will set the default directory before saving.
To set the default path of the Save dialog.
Dim dlgSaveDialog As New
SaveFileDialog dlgSaveDialog.InitialDirectory = “C:\Temp”
Save as previous version: This routine displays how to save a Visio 2000 or Visio 2002 document as a Visio 5 document. (With a note on how to save a Visio 2003 drawing as a Visio 2000/2002 document).
Public Sub SaveAsV5()
‘ Create a new file and save in Visio 5 format
Dim DocObj As Visio.Document, mastersObj As Visio.Masters, masterObj As Visio.Master
Dim PathName As String, FullFileName As String
‘ Set the default pathname
PathName = “C:\My Documents\”
Set DocObj = Documents.Add(“”)
DocObj.Version = &H50000
‘ For Visio 2000/2002 from Visio 2003 use: ‘
DocObj.Version = visVersion100
Set mastersObj = DocObj.Masters
Set masterObj = mastersObj.Add
FullFileName = PathName & “test.vsd”
DocObj.SaveAs FullFileName
DocObj.Close
End Sub
Save as V5 Dir: This is similar to the above routine, but it does it for all Visio files in a specific directory.
Sub SaveAsV5Dir()
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim FullFileName As String, NewPathName As String
Dim Dirs(500) As String, DirCnt As Integer, DirIndx As Integer
Dim DocObj As Visio.Document
‘ Set the default pathname
PathName = “C:\Visio\”
NewPathName = “C:\Visio\V5Files\”
‘ Set the default pathname
PathFileName = PathName & “*.vsd”
DirCnt = 0
CurrFileName = Dir(PathFileName)
Do While CurrFileName <> “”
DirCnt = DirCnt + 1
Dirs(DirCnt) = CurrFileName
CurrFileName = Dir
Loop
For DirIndx = 1 To DirCnt
CurrFileName = Dirs(DirIndx)
Debug.Print CurrFileName
FullFileName = PathName & CurrFileName
Debug.Print FullFileName
Set DocObj = Documents.Open(FullFileName)
DocObj.Version = &H50000
FullFileName = NewPathName & CurrFileName
Debug.Print FullFileName Debug.Print ” ”
DocObj.SaveAs FullFileName
DocObj.Close
Set DocObj = Nothing
Next DirIndx
End Sub
Select Shapes: This is a piece of sample code that shows how to work with the currently selected shapes. from John Marshall
Dim VsoSelect As Visio.Selection
Dim VsoShape as Visio.Shape
Set VsoSelect = Visio.ActiveWindow.Selection
If VsoSelect.Count > 0 Then
for each VsoShape in VsoSelect
next VsoShape
else
MsgBox “You Must Have Something Selected”
end if
Shape – List group members: This is a piece of sample code that loops through the shapes in a group and displays the names. It uses recursion to handle shape collections within shapes. from John Marshall – Visio MVP
Public Sub ListGroup()
Dim vsoSelect As Visio.Selection
Dim vsoShape As Visio.Shape
Dim vsoShapes As Visio.Shapes
Set vsoSelect = Visio.ActiveWindow.Selection
If vsoSelect.Count > 0 Then
For Each vsoShape In vsoSelect
Call ProcessShape(shp)
Next vsoShape
Else
MsgBox “You Must Have Something Selected”
End If
End Sub
Public Sub ProcessShape(shp As Visio.Shape)
Dim subshp As Visio.Shape
Debug.Print shp.Name
If shp.Shapes.Count > 0 Then
For Each subshp In shp.Shapes
Call ProcessShape(subshp)
Next subshp
End If
End Sub
MsgBox “You Must Have Something Selected”
end if
Setting LineWeight: This routine sets the line weight.
Dim VsoShape As Visio.shape, style As Visio.style
‘Select the shape
Set VsoShape = Visio.ActiveWindow.Selection.Item(1)
VsoShape.Cells(“LineWeight”).Formula = “4 pt.”
Stencil Printout: This routine will copy all masters in a stencil to a Visio document for printing.
Public Sub DisplayStencils()
‘ Create a sample document from the shapes in a stencil
Dim DocObj As Visio.Document, mstObj As Visio.Master
Dim pagesObj As Visio.Pages, pageObj As Visio.Page
Dim shpObj As Visio.Shape, stnObj As Visio.Document
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim FullFileName As String, MastrName As String
Dim Dirs(200) As String,
DirCnt As Integer, DirIndx As Integer
Dim ShapeTotal As Integer, curShapeIndx As Integer
Dim ShapeHeight As Visio.Cell, ShapeWidth As Visio.Cell
Dim ix As Integer, iy As Integer, tmpStr As String, tmpStr2 As String
Dim ShapeName(3000) As String, ShapeIndx(3000) As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim ZeroStr As String
Dim TmpChar As String
ZeroStr = “00000000000000” ‘
Set the default pathname
PathName = “C:\Visio\Stuff\”
‘ Set the default pathname
PathFileName = PathName & “*.vss”
DirCnt = 0
CurrFileName = Dir(PathFileName)
Do While CurrFileName <> “”
DirCnt = DirCnt + 1
Dirs(DirCnt) = CurrFileName
CurrFileName = Dir Loop
‘ DirCnt = 1
For DirIndx = 1 To DirCnt
Visio.Application.ScreenUpdating = False
Set DocObj = Documents.Add(“”)
Set pagesObj = DocObj.Pages
Set pageObj = pagesObj.Item(1)
CurrFileName = Dirs(DirIndx)
MastrName = Left(CurrFileName, Len(CurrFileName) – 4)
FullFileName = PathName & MastrName & “.vss”
Set stnObj = Documents.OpenEx(FullFileName, visOpenDocked)
ShapesCnt = stnObj.Masters.Count
Debug.Print “Number of Shapes”; ShapesCnt
If ShapesCnt > 3000 Then
Exit For
End If
For curShapeIndx = 1 To ShapesCnt
Set mstObj = stnObj.Masters(curShapeIndx)
ShapeIndx(curShapeIndx) = curShapeIndx
tmpStr = mstObj.Name: i2 = -1
For i1 = 1 To Len(tmpStr)
If i2 < 0 Then
TmpChar = Mid(tmpStr, i1, 1)
If InStr(1, “0123456789”, TmpChar) = 0 Then
i2 = i1 – 1
End If
End If
Next i1
If i2 < 0 Then
i2 = Len(tmpStr)
tmpStr2 = Left(tmpStr, i2) & ZeroStr
tmpStr = Left(tmpStr2, 12)
ShapeName(curShapeIndx) = tmpStr & mstObj.Name
‘ Debug.Print mstObj.Name; ” “; tmpStr; ” “; ShapeName(curShapeIndx)
Next curShapeIndx
‘ Sort the shapes using the adjusted location
For i1 = 1 To ShapesCnt
For i2 = i1 + 1 To ShapesCnt
If ShapeName(i1) > ShapeName(i2) Then
tmpStr = ShapeName(i1): i3 = ShapeIndx(i1)
ShapeName(i1) = ShapeName(i2): ShapeIndx(i1) = ShapeIndx(i2)
ShapeName(i2) = tmpStr: ShapeIndx(i2) = i3
End If
Next i2
Next i1
ix = -0.25: iy = 10.5
For curShapeIndx = 1 To ShapesCnt
ix = ix + 1 If ix > 8 Then
ix = 0.75: iy = iy – 1
If iy < 1 Then
ix = 0.75: iy = 10.5
Set pageObj = pagesObj.Add
End If
End If
i1 = ShapeIndx(curShapeIndx)
Debug.Print ShapeName(curShapeIndx)
Set mstObj = stnObj.Masters(i1)
Set shpObj = pageObj.Drop(mstObj, ix, iy)
shpObj.Text = mstObj.Name
Next curShapeIndx
FullFileName = PathName & MastrName & “.vsd”
DocObj.SaveAs FullFileName
DocObj.Close
Set DocObj = Nothing
Visio.Application.ScreenUpdating = True Next DirIndx End Sub
Table of Contents: Create a Table of Contents with hyper links for a Visio drawing. from Zack Moore Microsoft Sub CreateTableOfContents() ‘ creates a shape for each page in the drawing on the first page of the ‘ drawing then adds a hyperlink to each shape so you can click and go ‘ to that page ‘ define a toc shape Dim TOCEntry As Visio.Shape Dim PageToIndex As Visio.Page Dim X As Integer Dim hlink As Visio.Hyperlink ‘ loop through all the pages you have For Each PageToIndex In Application.ActiveDocument.Pages   ‘ you may want to refine this and use a top down algorithm with   ‘ something smaller than 1 inch increments.   X = PageToIndex.Index   ‘ draw a rectangle for each page to hold the text   Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, X, 4, X + 1)   ‘ write the page name in the rectangle   TOCEntry.Text = PageToIndex.Name   ‘ add a hyperlink to point to the page to you can just go there   ‘ with a click   ‘ need to create a handle to add the hyperlink   Set hlink = TOCEntry.AddHyperlink   ‘ add a description   hlink.Description = PageToIndex.Name   ‘ add the page name as an address   hlink.SubAddress = PageToIndex.Name Next End Sub
Table of Contents: Create a Table of Contents with Goto Page links. This is my version of Zack’s program.
Sub TableOfContents()
‘ creates a shape for each page in the drawing on the first page of the drawing
‘ then add a dbl-clk GoTo to each shape so you can double click and go to that Page
Dim PageObj As Visio.Page
Dim TOCEntry As Visio.Shape
Dim CellOjb As Visio.Cell
Dim PosY As Double
Dim PageCnt As Double
‘ ActiveDocument.Pages.Count will give the number of pages, but we are interested
‘ the number of foreground pages
PageCnt = 0
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then PageCnt = PageCnt + 1
Next
‘ loop through all the pages
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then ‘ Only foreground pages
‘ where to put the entry on the page?
PosY = (PageCnt – PageObj.Index) / 4 + 1
‘ draw a rectangle for each page to hold the text
Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, PosY, 4, PosY + 0.25)
‘ write the page name in the rectangle
TOCEntry.Text = PageObj.Name
‘ add a link to point to the page to you can just go there with a Double Click
Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick) ‘Start
CellObj.Formula = “GOTOPAGE(“”” + PageObj.Name + “””)”
End If
NextEnd Sub
Word: This is the VBA instruction for inserting a Visio diagram in Word.
This code is added to a Word VBA procedure.
Selection.InlineShapes.AddOLEObject ClassType:=”Visio.Drawing”, _ FileName:=”c:\Divided Bar.vsd”, LinkToFile:=False, DisplayAsIcon:=False

Written by johnvisiomvp

April 4, 2017 at 3:17 pm

%d bloggers like this: