Find Replace Custom Properties

[damswil]

So I looked thru the site and this problem is referenced multiple times and it seems like every answer is "its somewhere on the forum" or there is a broken link so I'm re-posting, sorry to those who have seen this question before.

Does anyone have handy, code that will allow you to run a Find & Replace on Custom Property text?

[wapperdude]

Just to be clear, are you wanting to find and replace the contents of the custom property or find and replace the custom property itself?

The basic tool is the strcomp vba function.  There are a lot of examples on the net.  The other part of this are some nested loops...if your Visio file has multiple pages, you need to go thru each page.  Then, on each page you need to loop thru all the shapes.  Finally, you loop thru each shape searching the shape data section for those that meet your fine / replace criteria.

Yes, there are a lot of related items in the forum and on the net, so you need to build your code from those those various examples.  I doubt anyone has done your specific case.  If you've not done VBA before, or are unsure, help is available, we just need more info.

Wapperdude

[damswil]

Yeah just find/replacing custom property contents on a single page for multiple shapes. Each shape is basically identical just the contents of the properties change, so I can loop thru each shape easily enough, just not sure of how I would run a find/replace for its contents.

[wapperdude]

How would you provide the data for replacement?  Read from a source?  Have code open up shapesheet and then enter by hand?  Hardcode the replacement into VBA and do and let code do it?

For example, the following untested code has hardcode entries.  You enter the old value and enter the new value into the code.  Save and run.

Code Select Expand


Sub FindReplaceShpData()
    Dim vsoShp As Shape
    Dim myNewTxt As String, OldTxt As String
    Dim i As Integer
    Dim nRows As Integer

    OldTxt = "Enter existing string here"
    myNewTxt = "Enter new text here"
   
    For Each vsoShp In ActiveDocument.Pages(1).Shapes
        If vsoShp.Master <> "Dynamic connector" Then
            nRows = vsoShp.RowCount(Visio.visSectionProp)                                                            'number of rows in Shape Properties section
            For i = 0 To nRows - 1                                                                                  'Search all rows for value cell = Engineer
                If vsoShp.CellsSRC(Visio.visSectionProp, i, 0).ResultStr(Visio.visNoCast) = Chr(34) & OldTxt & Chr(34) Then
                    vsoShp.CellsSRC(Visio.visSectionProp, i, 0).FormulaForceU = Chr(34) & myNewTxt & Chr(34)
                End If
            Next i
        End If
    Next
End Sub

Wapperdude

[damswil]

I was going to have a userform with "find" and "replace" text boxes. I had something similar to what you've provided. The real problem I am having is trying to run it like the true find/replace feature. For instance if I had a string of text = "It is a warm and sunny day." , and I wanted to replace it with "It is a warm and cloudy day." I don't want to run a find and replace on the entire string, I would just want to enter "sunny" into FIND and "cloudy" into REPLACE. Thanks for your help so far.

[wapperdude]

For something like that, this code will work.  If your shapedata had the entry:  "The big, black canary."  The word to replace in the string is "black".  The new word will be "yellow".

Code Select Expand


Sub FindReplaceShpData()
    Dim vsoShp As Shape
    Dim myNewTxt As String, OldTxt As String, vsoChars1 As String
    Dim i As Integer
    Dim nRows As Integer

    myNewTxt = "yellow"
   
    For Each vsoShp In ThisDocument.Pages(1).Shapes
        nRows = vsoShp.RowCount(Visio.visSectionProp)                                                            'number of rows in Shape Properties section
        For i = 0 To nRows - 1                                                                                                   'Search all rows and fetch entire content
            OldTxt = vsoShp.CellsSRC(Visio.visSectionProp, i, 0).ResultStr(none)
            vsoChars1 = Replace(OldTxt, "black", myNewTxt)                                                        'Replace the word black in the string.  It not found, do nothing
            vsoShp.CellsSRC(Visio.visSectionProp, i, 0).FormulaForceU = Chr(34) & vsoChars1 & Chr(34)   'Re-populate the cell with the corrected string of text
        Next i
    Next
End Sub


Wapperdude

[damswil]

Yeah that worked amazingly, thanks a bunch for your help.

[wapperdude]

...,and a slightly friendlier version that makes defining the target and replacement text entries easier.

Code Select Expand


Sub FindReplaceShpData()
'Friendly version.  Easier to define the "find" and "replacement" text.
'
    Dim vsoShp As Shape
    Dim repTxt As String, theTxt As String, fndTxt As String
    Dim i As Integer
    Dim nRows As Integer

    fndTxt = "black"
    repTxt = "yellow"
   
    For Each vsoShp In ActiveDocument.Pages(1).Shapes
        nRows = vsoShp.RowCount(Visio.visSectionProp)                                                                              'number of rows in Shape Properties section
        For i = 0 To nRows - 1                                                                                                                    'Search all rows
            theTxt = Replace(vsoShp.CellsSRC(Visio.visSectionProp, i, 0).ResultStr(none), fndTxt, repTxt)         'Replace fndTxt with repTxt in the string.  It not found, do nothing
            vsoShp.CellsSRC(Visio.visSectionProp, i, 0).FormulaForceU = Chr(34) & theTxt & Chr(34)                'Re-populate the cell with the corrected string of text
        Next i
    Next
End Sub