VBA not finding all expected shapes

[KeithRuck]

I have an orgchart (fully expanded) and I had some code I used last April to grab EMF files and place them in the orgchart to provide more information. I just tried to recreate my orgcharts with updated data, and for some reason it isn't working as expected.

The target (active) sheet has a total of about 129 people.
Application.ActivePage.Shapes.Count = 257
# of connectors (see code below) = 51 (iCount)
# of shapes that run through the upper code block = 206  (iCount2)

Each shape has 4 data fields; name, location, title, and User ID. The first 3 are visible on the shape, whereas the User ID is a hidden data field. User ID is a 5-digit string, but only the last 3 digits are unique. The EMF files are named with just the 3 digits, which is why this code has to parse them out the 3-digit User ID.

The problem? Only about 38 of the shapes are receiving the EMF files. I checked one of the shapes that didn't get an EMF file imported with this code, and the User ID is in that shape just like the others, and there is an appropriately named EMF file.

I'd really appreciate it if you could take a look at the code, and see if there is some obvious reason that it would be skipping a bunch of my shapes!

The only other thing I'm not sure about- the field from Excel was "User ID" but when referencing the property (even though it is in quotes) it won't accept "prop.User ID" [it errors out]- it only runs when I use "prop.UserID" without the space.

Code Select Expand


Sub ShapesCount()
    'Return value
    Dim iCount As Integer
    'Shapes collection
    Dim shpsObj As Visio.Shapes
    'Shape object
    Dim shpObj As Visio.Shape

    iCount = 0
    'Assumes root.Shapes is a group or a page
    ShpsCount = Application.ActivePage.Shapes.Count
    Set shpsObj = Application.ActivePage.Shapes ' root.Shapes
    For UseShpObj = ShpsCount To 1 Step -1
    Set shpObj = shpsObj(UseShpObj)
        If shpObj.Type = visTypeGroup And shpObj.Style <> "Connector" Then
            iCount2 = iCount2 + 1
               'NOTE: whatever comes after "Prop." has to match the
               'name of the background field that was added from Excel
            a3 = shpObj.Cells("Prop.UserID").ResultStr(Visio.VisUnitCodes.visNoCast) 'returned as basic string
            a3 = UCase(Right(Trim(a3), 3)) 'get the unique 3-char string User ID
            Debug.Print "." & a3
                'note: only 44 items are debug/printed here, instead of 129, so the issue is above this line
            If a3 = "DAH" Then MsgBox "stop here" 'this line is never triggered
            b1 = shpObj.Cells("PinX").ResultIU
            b2 = shpObj.Cells("PinY").ResultIU
            b3 = shpObj.Cells("Height").ResultIU
            b4 = shpObj.Cells("Width").ResultIU
           
            HalfHeight = b3 * 0.5
            UpperPinY = b2 + (HalfHeight * 0.5)
            LowerPinY = b2 - (HalfHeight * 0.5)


            'Right now, this uses the same two filenames, later it will use two different files
            MyFileName = "C:\Documents and Settings\iezac\Desktop\Jane Charts\Colors3\" & a3 & "_all.emf"
            MyFileName2 = "C:\Documents and Settings\iezac\Desktop\Jane Charts\Colors3\" & a3 & "_all.emf"
            If Dir(MyFileName) <> "" Then
                shpObj.Cells("FillPattern").FormulaU = 0
                With Application.ActiveWindow
                    Set vsoShape = .Page.Import(MyFileName)
                    On Error GoTo 0
                    vsoShape.Cells("PinX").FormulaU = b1
                    vsoShape.Cells("PinY").FormulaU = UpperPinY
                    vsoShape.Cells("Height").FormulaU = HalfHeight
                    vsoShape.Cells("Width").FormulaU = b4
                    vsoShape.SendToBack
                End With
            End If
            If Dir(MyFileName2) <> "" Then
            shpObj.Cells("FillPattern").FormulaU = 0
                With Application.ActiveWindow
                    Set vsoShape = .Page.Import(MyFileName2)
                    On Error GoTo 0
                    vsoShape.Cells("PinX").FormulaU = b1
                    vsoShape.Cells("PinY").FormulaU = LowerPinY
                    vsoShape.Cells("Height").FormulaU = HalfHeight
                    vsoShape.Cells("Width").FormulaU = b4
                    vsoShape.SendToBack
                End With
            End If
           
        Else
            iCount = iCount + 1
            If shpObj.Style <> "Connector" Then
                Debug.Print shpObj.Text
            End If
        End If
    Next
   
    MsgBox iCount & vbCrLf & iCount2
End Sub


[KeithRuck]

Here is an interesting observation- I just noticed that while the majority of the shapes with EMF files remains stable, there appears to be some variation. The code makes the Visio shape transparent (the EMF goes behind it).

Each time I re-run it, I start by deleting all non-visio shapes from the sheet (which gets rid of the EMF shapes as expected).

As I look closely, I see some shapes that are transparent but are not receiving an EMF shape with each run- so they must have gotten them at one time, but aren't now. I also had one of the ones I was testing show up on two runs without any changes to the code.

I added a DoEvents, in case it was strictly a timing thing, but that didn't have a noticable effect. Maybe I need a 1-s delay in there somewhere? The question is where...

Thanks for your continued support,
Keith

[Paul Herber]

After a very quick look at your code, be very careful, your loop through all the shapes is effectively being modfied by the code "vsoShape.SendToBack", SendToBack changes the order of the shapes in the shapes collection.

[KeithRuck]

ooooohhhh. I didn't realize that would change the order. Sounds like I need to loop all the shapes before starting and identify them in a separate array that will remain in the original order, rather than dynamically going through them on the page. I'll go try that, and report back when I've got it running to confirm the results.

Thanks!!
Keith

[KeithRuck]

This appears to have worked! Now I'll go back and cross reference the original data to make sure things are ending up where they should, but it looks like all the EMF files are loading- thank you thank you thank you!

Best,
Keith

Code Select Expand


Sub ShapesCount()
    'Shapes collection
    Dim shpsObj As Visio.Shapes
    'Shape object
    Dim shpObj As Visio.Shape
    'NEW: Copy of original array of shapes to avoid changing order with "SendToBack"
    Dim ShpsArray()

    'Assumes root.Shapes is a group or a page
    ShpsCount = Application.ActivePage.Shapes.Count
    Set shpsObj = Application.ActivePage.Shapes ' root.Shapes
   
    'NEW: make a copy of the original list of shapes
    ReDim ShpsArray(1 To ShpsCount)
    For UseShpObj = 1 To ShpsCount
        Set ShpsArray(UseShpObj) = shpsObj(UseShpObj)
    Next
   
    For UseShpObj = 1 To ShpsCount 'To 1 Step -1
    Set shpObj = ShpsArray(UseShpObj) '<-- RTE 424, object required
    <snip>


[Jumpy]

Hello,
some general questions about loops (I asked myself because of this code)
KeithRuck and several other examples I've seen here and elsewhere on the web loop through the Shapes on the page with Indexnumber like

For i = 1 to ...Shapes.Count
debug.Print shp(i).Name
Next

or they count backwards like KeithRuck

For i = ...Shapes.Count To 1 Step -1
debug.Print shp(i).Name
Next

First question: Is there a difference between those two code examples, a reason why one is used and not the other?

Second question: When I had to loop through all the Shapes I used sth. like this:

For Each shp in ActivePage.Shapes
debug.Print shp.Name
Next

I seldom saw this kind of loop and asked myself, is it not good two use it so? Are the ones above better? And if so, why?
Would this loop also have been affected by the error above?

I'm new to programming (Visio) and still learning and optimizing my code and therefore would be thankfull if one of the old hands had time for a little lesson and could answer my questions.

Thanks,
Jumpy

P.S.: Feel free to move this post, if you think it doesn't belong here, or should be a new thread.