I've got a small piece of code that steps through shapes on a page, adds a new page then renames it with the text field of the shape on the first page. This works fine and is basically just two lines of code:
Sub AddLevel4(PName As String, L3Name As String)
Set vsoNewPage = ActivePage.Duplicate
vsoNewPage.Name = PName
End Sub
What I want to do is select a single shape on that new page, add the contents of "L3Name" to the shape text and also add a hyperlink (subaddress), again the contents of "L3Name", back to the original page.
I've been pulling (what's left of) my hair out just trying to select the shape to use (I know it's ID), but nothing I've tried gets me even close.
This is the "calling" sub:
Sub Level4Name()
' This routine steps through all the shapes in a document and identifies all the Level 4 Processes.
Dim vsoDocument As Visio.Document
Dim pg As Visio.Page
Dim shp As Visio.Shape
Dim shp1 As Visio.Shape
Dim filePath As String
filePath = "P:\Level4s.txt"
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject
Dim fileStream As TextStream
Dim NumProc As Integer
Set fileStream = FSO.CreateTextFile(filePath)
Dim vsoHyperlink As Visio.Hyperlink
Dim vsoNewPage As Visio.Page
If MsgBox("Do you really want to create Level 4 Process Diagrams from shapes in the document?", vbYesNo) = vbNo Then Exit Sub
If MsgBox("Please confirm once more.", vbYesNo) = vbNo Then Exit Sub
For Each pg In ActiveDocument.Pages
L3Name = pg.Name
For Each shp In pg.Shapes
If StringCountOccurrences(shp.Text, ".") = 3 Then
Debug.Print "(" & StringCountOccurrences(shp.Text, ".") & ")" & shp.Text
fileStream.WriteLine shp.Text
' MakeLevel4 (shp.Text)
AddLevel4 (shp.Text)
Set vsoHyperlink = shp.AddHyperlink
' vsoHyperlink.Description = ActiveDocument.Name
vsoHyperlink.SubAddress = shp.Text
NumProc = NumProc + 1
End If
Next
Next
fileStream.Close
MsgBox (NumProc & " Level 4 Processes created.")
End Sub
And the associated Function:
Function StringCountOccurrences(strText As String, strFind As String, _
Optional lngCompare As VbCompareMethod) As Long
' Counts occurrences of a particular character or characters.
' If lngCompare argument is omitted, procedure performs binary comparison.
'Testcases:
'?StringCountOccurrences("","") = 0
'?StringCountOccurrences("","a") = 0
'?StringCountOccurrences("aaa","a") = 3
'?StringCountOccurrences("aaa","b") = 0
'?StringCountOccurrences("aaa","aa") = 1
Dim lngPos As Long
Dim lngTemp As Long
Dim lngCount As Long
If Len(strText) = 0 Then Exit Function
If Len(strFind) = 0 Then Exit Function
lngPos = 1
Do
lngPos = InStr(lngPos, strText, ".", lngCompare)
lngTemp = lngPos
If lngPos > 0 Then
lngCount = lngCount + 1
lngPos = lngPos + Len(strFind)
End If
Loop Until lngPos = 0
StringCountOccurrences = lngCount
End Function
Does anybody have any pointers?
FWIW I ended up with a slightly different solution - adding a shape then naming/linking it.
Sub CreateBackLink()
Dim vsoWindow As Visio.Window
Set vsoWindow = ActiveWindow
Dim vsoStencil As Visio.Master
Dim vsoShape As Visio.Shape
Dim vsoPage As Visio.Page
Dim vsoHyperlink As Visio.Hyperlink
L3Name = "Level 3 Page"
PName = "Level 4 Shape"
Set vsoPage = Application.ActiveWindow.Page
Set vsoStencil = Application.Documents.Item("T:\Visio\New Process Stencil.vssm").Masters.ItemU("Controlling Process")
Set vsoShape = vsoPage.Drop(vsoStencil, 166.2421, 173.4)
Set vsoHyperlink = shp.AddHyperlink
vsoHyperlink.Description = L3Name
vsoHyperlink.SubAddress = PName
End Sub
Probably not as elegant as it could be, but seems to work.