Looping to update LineWeight

[deltab]

Hi all, struggling with a loop. I'm new to VBA and I've cobbled a few examples together but unable to get the loop right.

Summary: I have a bunch of shapes with some ShapeData attached. I'd like to iterate through shapes with a certain value and then increase the Shape LineWeight on those.

Tried a few things like Selection and Array, but not quite working. Any help much appreciated. I think I'm trying to create an index of shapes with a certain value then loop through those, but not sure how.

Code Select Expand

Option Explicit


Public Sub changeLineWidthAllShapesOnPage()

    Dim visPage As Visio.Page
    Set visPage = Application.ActivePage
    Dim visShape As Visio.Shape
    Dim strLineWeight As String
    strLineWeight = "6 pt"
           
      For Each visShape In visPage.Shapes
       
        changeLineWidthOfShape visShape, strLineWeight
   
    Next visShape
   


End Sub


'
' change line weight
'
Private Sub changeLineWidthOfShape _
        (ByVal visShape As Visio.Shape, _
        ByVal strLineWeight As String)
       
        On Error GoTo ErrHandler

        Dim visSubShape As Visio.Shape
           
        If visShape.Type = visTypeGroup Then
            For Each visSubShape In visShape.Shapes
                changeLineWidthOfShape visSubShape, strLineWeight
            Next visSubShape
        End If
        Dim visCell As Visio.Cell
        Set visCell = visShape.CellsSRC(visSectionObject, visRowLine, visLineWeight)
        visCell.FormulaForce = strLineWeight
        Exit Sub
       
ErrHandler:

    Debug.Print Err.Description
       
       
End Sub


[Yacine]

What is not working? Looks fine at a first glance.
Run the macro line by line and tell us where the problem is.

[wapperdude]

It looks like the error is in this line:
Set visCell = visShape.CellsSRC(visSectionObject, visRowLine, visLineWeight)

From what I can tell, visRowLine has no value assigned to it...unless I missed something.

Wapperdude

[vojo]

neither is section object

[wapperdude]

Went back and more carefully looked at the code, I agree with Yacine, seems good.  Tried the code as provided.  Works fine.  Finds subshapes in group, everything gets new line width.

Wapperdude

[deltab]

Hi all. Thanks for the speedy responses.

It's the loop element that I'm struggling with, so as Wrapperdude says - it redraws every line width, whereas I need it to only redraw all shapes with the shape property i'm interested in,  I'm trying to find a method to identify all shapes with a certain shapedata and ONLY change those. But unsure how to inject this into the code I have already.

Code Select Expand


For Each visShape in '//bunch of shapes I've identified from their Cells("Prop.MyProp")

If visShape.Cells("Prop.MyProp") = "A" Then

changeLineWidthOfShape visShape, strLineWeight

EndIf
Next


Thanks again and thanks for taking the time to help. Much appreciated.

[deltab]

Having a bit more of a play. I'm looking for something like this. Except this gives me an unexpected EOF.

Code Select Expand


Public Sub changeLineWidthAllShapesOnPage()

    Dim visPage As Visio.Page
    Set visPage = Application.ActivePage
    Dim visShape As Visio.Shape
    Dim strLineWeight As String
    strLineWeight = "6 pt"
           
      For Each visShape In visPage.Shapes
        If visShape.CellsU("Prop.Row_1") = True Then
        changeLineWidthOfShape visShape, strLineWeight
        End If
    Next visShape
End Sub


'
' change line weight
'
Private Sub changeLineWidthOfShape _
        (ByVal visShape As Visio.Shape, _
        ByVal strLineWeight As String)
       
        On Error GoTo ErrHandler

        Dim visSubShape As Visio.Shape
           
        If visShape.Type = visTypeGroup Then
            For Each visSubShape In visShape.Shapes
                changeLineWidthOfShape visSubShape, strLineWeight
            Next visSubShape
        End If
        Dim visCell As Visio.Cell
        Set visCell = visShape.CellsSRC(visSectionObject, visRowLine, visLineWeight)
        visCell.FormulaForce = strLineWeight
        Exit Sub
       
ErrHandler:

    Debug.Print Err.Description
       
       
End Sub


[wapperdude]

Your test checks to see if Prop.Row_1 contains Boolean true.  Is that what you want?  Is this where the code fails?  You need to Do an additional check to verify that he cell exists.  Also, you ought to use .result("") to fetch the result.

The following should be close, but not at my computer, so can't verify it...

Example,

Code Select Expand

If shp.CellExists("Prop.Row_1", False) Then
             If shp.Cells("Prop.Row_1").Result("") then
                   ... your code....

             End if
         End if


Since the check is for Boolean true, that is the default syntax of the IF  statement

Wapperdude

[wapperdude]

Had time to go thru the "filtering" fcn.  I used User Defined entry:  user.ItsMe = True or False.  Modified your code to check / use the filter:

Code Select Expand


Private Sub changeLineWidthOfShape(ByVal visShape As Visio.Shape, ByVal strLineWeight As String)
'
' change line weight
'
    Dim visCell As Visio.Cell
    Dim visSubShape As Visio.Shape
       
    On Error GoTo ErrHandler
       
    If visShape.Type = visTypeGroup Then
        For Each visSubShape In visShape.Shapes
            changeLineWidthOfShape visSubShape, strLineWeight
        Next visSubShape
    End If
    If visShape.CellExists("User.ItsMe", True) Then
        If visShape.CellsU("User.ItsMe").Result("") Then
            Set visCell = visShape.CellsSRC(visSectionObject, visRowLine, visLineWeight)
            visCell.FormulaForce = strLineWeight
        End If
    End If
Exit Sub
       
ErrHandler:
    Debug.Print Err.Description
       
End Sub



The above code only changes the lineweights if the shape has the entry, User.ItsMe, and if that entry is TRUE or (1).

You can change the IF filter as needed.  Note, another format would be visShape.CellsU("User.ItsMe").Resultstr("visNone")

Note, if you only need to know that desired property exists, then you don't need the 2nd nested IF test.  But, if you do need to check the entry value, then you may need to use the results structure plus the strsame fcn.

This should get you going.
Wapperdude