Author Topic: Selecting a single shape on a page, adding text and a hyperlink to it  (Read 379 times)

0 Members and 1 Guest are viewing this topic.

Mike Oxsaw

  • Newbie
  • *
  • Posts: 2
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:
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:
Code
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:
Code
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?

Mike Oxsaw

  • Newbie
  • *
  • Posts: 2
Re: Selecting a single shape on a page, adding text and a hyperlink to it
« Reply #1 on: January 19, 2021, 10:17:02 AM »
FWIW I ended up with a slightly different solution - adding a shape then naming/linking it.

Code
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.