What's with shape selection, shape text?

[wapperdude]

The topics and needs to work with shape text and selecting shapes comes up quite often.  So, this post tries to address these issues by giving examples of VBA syntax.  Hopefully, there will be more contributions than the initial offerings that I present here.  I'm attaching a file and posting the code for those who just want to copy/paste.

There are half a dozen subs.  Some of the subs have two or more code methods.  The topics include copying some or all text, catenating text from various shapes, pasting/replacing all or parts of text.  In addition, there are multiple ways to select / use shapes, both individually and iterate thru a collection of shapes.  The focus is mainly syntax, which can be modified for specific needs.

This is by no means an exhaustive treatment of these topics, but, provides starting point examples.

Enjoy!
Wapperdude

Code Select Expand


Sub ChgText()
     Dim vsoPage As Visio.Page, vsoShape As Visio.Shape
    Dim vsoCharacters1 As Visio.Characters, vsoStrng As String, vsoMyText As String
    vsoMyText = "NewText"
'    vsoMyText = Chr(34) & vsoMyText & Chr(34)
   
    For Each vsoPage In ThisDocument.Pages
        For Each vsoShape In vsoPage.Shapes
            Set vsoCharacters1 = vsoShape.Characters
            vsoStrng = vsoCharacters1.Text                  'This step not necessary, vsoCharacters1.Text could be placed directly in the formula on the next line.
            vsoCharacters1.Text = Replace(vsoStrng, "MyText", vsoMyText)
        Next
    Next
End Sub
Sub TxtPaste()
'Note, assumes sheet.1 is the desired shape.

    Dim vsoCharacters1 As Visio.Characters
    Dim vsoCharacters2 As Visio.Characters
   
'Define text for copying:
    Set vsoCharacters1 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters1.Begin = 8
    vsoCharacters1.End = 14
    vsoCharacters1.Copy

'Define new text location and paste old text:
    Set vsoCharacters2 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters2.Begin = 24
    vsoCharacters2.End = 31
    vsoCharacters2.Paste

End Sub
Sub TxtPaste2()
'Note, assumes sheet.1 is the desired shape.

    Dim vsoCharacters1 As Visio.Characters
    Dim vsoCharacters2 As Visio.Characters
   
'Define text for copying:
    Set vsoCharacters1 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters1.Begin = 8
    vsoCharacters1.End = 14
    vsoCharacters1.Copy

'Make selected shape the active shape for text pasting:
    Set vsoShp = ActivePage.Shapes.ItemFromID(1)
    ActiveWindow.Select vsoShp, visSelect   'This makes the shape ACTIVE

'Define new text location and paste old text:
    Set vsoCharacters2 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters2.Begin = 24
    vsoCharacters2.End = 31
    ActiveWindow.SelectedText = vsoCharacters2
    ActiveWindow.SelectedText.Paste

End Sub
Sub selShp()
'Various code techniques to select a shape.
'Shows the syntax needed.
'Uncomment or copy / modify the desired method as needed.
    Dim vsoShp As Shape
   
'Manually preSelected:
'    Set vsoShp = ActiveWindow.Selection(1)
'    Debug.Print vsoShp

'Based upon ID:
'    Set vsoShp = ActivePage.Shapes.ItemFromID(1)
'    ActiveWindow.Select vsoShp, visSelect   'This makes the shape ACTIVE
'    Debug.Print vsoShp
   
'Following methods are for stepping thru multiple shapes on a page.
'The 1st is good for deleting shapes, but you MUST progress from highest ID to lowest.
'Thus, the FOR statement would be:
'For i = shpCnt To 1 Step -1

'Method1:
'    shpCnt = ActivePage.Shapes.Count
'    For i = 1 To shpCnt Step 1
'        Set vsoShp = ActivePage.Shapes.ItemU(i)
'        Debug.Print vsoShp
'    Next
     
'or Method2:
'    For Each vsoShp In ActivePage.Shapes                                       'Checks every shape on each page
'        Debug.Print vsoShp
'    Next

End Sub
Sub CatNRpl()
'This macro copies all text from shapes 1 - 3
'Catenates the 3 text strings and pastes into shape 4.
'
    Dim shpChrs1 As Visio.Characters
    Dim shpChrs2 As Visio.Characters
    Dim shpChrs3 As Visio.Characters
    Dim shpChrs4 As Visio.Characters
   
    Set shpChrs1 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    Set shpChrs2 = ActiveWindow.Page.Shapes.ItemFromID(2).Characters
    Set shpChrs3 = ActiveWindow.Page.Shapes.ItemFromID(3).Characters
    Set shpChrs4 = ActiveWindow.Page.Shapes.ItemFromID(4).Characters
   
    shpChrs4 = shpChrs1 & Chr(10) & shpChrs2 & Chr(10) & shpChrs3
       
End Sub
Sub CatNRpl2()
'Alternate technique, same amount of coding
'This macro copies all text from shapes 1 - 3
'Catenates the 3 text strings and pastes into shape 4.
'
    Dim shpChrs1 As Visio.Characters
    Dim shpChrs2 As Visio.Characters
    Dim shpChrs3 As Visio.Characters
    Dim vsoShp As Visio.Shape
   
    Set shpChrs1 = ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    Set shpChrs2 = ActiveWindow.Page.Shapes.ItemFromID(2).Characters
    Set shpChrs3 = ActiveWindow.Page.Shapes.ItemFromID(3).Characters
   
    Set vsoShp = ActivePage.Shapes.ItemFromID(4)
'    ActiveWindow.Select vsoShp, visSelect   'Optional:  this makes the shape ACTIVE
    vsoShp.Text = shpChrs1.Text & Chr(10) & shpChrs2.Text & Chr(10) & shpChrs3.Text
   
End Sub