Using VBA to parse shapesheets

[MMZ_TimeLord]

Okay, I'm new here, but I've been working on this for nearly a week solid.  I feel as though I've read nearly the entire Visio and Visual Basic sections in MSDN and various searches on the subject on the net and heavily on this site and for the life of me can't seem to figure it out without doing a REALLY long brute force script for my task.

Task: To parse various shape's shapesheets through a VBA script/macro to collect geometry, size and style data for translation and export to a custom file format.

I've figured out how to use a private function to parse as many sub groups as anyone may have in a single group for their individual shapes. I've figured out how to add the data to a large text variable and output it to a file.

What I have NOT figured out is how to parse more than one geometry section. How in blue blazes, do you direct the script to cycle or move to the next geometry section!?!?!?

I know they are named geometry1, geometry2, etc. I also know how to get the number of sections in a given shape.

The problem is how to change the name from geometry1 to geometry2, etc... is there some kind of 'next section' or section number we can use to gather this data? Lastly, why is it NEVER mentioned how to extract the row type from a geometry section? (i.e. "MoveTo", "DrawTo", "Ellipse", etc.)

Oh, and using shapeholder.CellsSRC(s,r,c) gets me crap. The data matches only a fraction of the actual shapesheet, even when forced to 14 sections, 30  rows and cells.

Pulling Standard Shape Transformation data, etc. is fairly easy as it's consistent and I can hard code it. What I really NEED is all the geometry data.

I know I could export the drawing as a .VSX (XML) or similar and just parse the file, but that's even more work as I still have to take the existing data and then transform it for export to a custom format. Double and triple parsing is NOT what I want to do if I can help it.

As an added bonus, I'd love to keep the shapesheet formulas, Boolean types, etc. in the same form in my gathered data.

Sorry for the ramble, ... Help! 

[AndyW]

The geometry is in the section visSectionFirstComponent,

vsoShape.RowCount(visSectionFirstComponent)  will give you the number of geometry rows

To access the geometry data, e.g.

for i = 0 to vsoShape.RowCount(visSectionFirstComponent)-1

  debug.print vsoShape.CellsSRC(visSectionFirstComponent, i, visX).ResultIU

next

[MMZ_TimeLord]

Andy,

I'd  like to thank you for that post. It was the compass I needed to get back on track. I began with your basic example, added it to my current macro and expanded it to do what I wanted. YAY!... one step closer!

Check the code and see what you think. So far the data is as expected, but I'd still like to keep the formulas displayed in the shapesheet window from the cells. I'm sure there's some function or translation option I'm missing.

This is still more than good enough to get the data out and into a workable format and manipulate it as I want.

Thanks again!

Code Select Expand

Sub GeoPullTest3()

    '
    ' Pulls Geometry data from all selected shapes and sub-shapes
    '
    '              Created by MMZ_TimeLord
    '                Version 0.1  2010-03-09
    '
   
    Dim shpGrp As Visio.Shape   'Shape holder for this macro
    Dim GeoInfo As String       'String to save the resulting data
    Dim gs As Integer           'Counter for Geometry sections
    Dim gr As Integer           'Counter for Geometry section Rows

    ' Operate on all shapes that are currently selected:
    For Each shpGrp In ActiveWindow.Selection
       
        ' Get the current Shape Transform section:
        GeoInfo = GeoInfo + "Width = " & shpGrp.Cells("Width") & Chr(13)
        GeoInfo = GeoInfo + "Height = " & shpGrp.Cells("Height") & Chr(13)
        GeoInfo = GeoInfo + "Angle = " & shpGrp.Cells("Angle") & Chr(13)
        GeoInfo = GeoInfo + "PinX = " & shpGrp.Cells("PinX") & Chr(13)
        GeoInfo = GeoInfo + "PinY = " & shpGrp.Cells("PinY") & Chr(13)
        GeoInfo = GeoInfo + "LocPinX = " & shpGrp.Cells("LocPinX") & Chr(13)
        GeoInfo = GeoInfo + "LocPinY = " & shpGrp.Cells("LocPinY") & Chr(13)
       
        ' Get the current Shape Geometry section count:
        GeoInfo = GeoInfo + "GeoCount = " & shpGrp.GeometryCount & Chr(13)
       
        ' If Geometry sections exist...
        If shpGrp.GeometryCount > 0 Then
       
            ' Get all Geometry sections one at a time.
            For gs = visSectionFirstComponent To (visSectionFirstComponent + shpGrp.GeometryCount)
   
                ' Get all of the Rows in the current Geometry section.
                For gr = 0 To shpGrp.RowCount(gs) - 1
                   
                    ' Currently I am only getting the Row Type, X and Y cells.
                    GeoInfo = GeoInfo + "GeoRowType = " & _
                    shpGrp.RowType(gs, gr) & Chr(13)
                    GeoInfo = GeoInfo + "GeoCell-X = " & _
                    shpGrp.CellsSRC(gs, gr, visX).ResultIU & Chr(13)
                    GeoInfo = GeoInfo + "GeoCell-Y = " & _
                    shpGrp.CellsSRC(gs, gr, visY).ResultIU & Chr(13)
                   
                Next gr
               
            Next gs
       
        End If
       
        ' If there are sub Shapes in the current group...
        If shpGrp.Shapes.Count > 0 Then
           
            ' Process them through the GeoSubInfoPull() Private Funcion.
            GeoInfo = GeoInfo + GeoSubInfoPull(shpGrp)
        End If

    Next shpGrp
   
    ' Dump the results for observation.
    Debug.Print GeoInfo

End Sub

Private Function GeoSubInfoPull(ByRef PshpGrp As Visio.Shape) As String

    Dim PshpSub As Visio.Shape      'subShape holder for this macro
    Dim Pgs As Integer              'Counter for Geometry sections
    Dim Pgr As Integer              'Counter for Geometry section Rows
   
    ' Process all sub Shapes within the passed Shape.
    '   (no, it does not have to be a Shape collection)
    For Each PshpSub In PshpGrp.Shapes
   
        '// Get the current geometry section of the sub-shape:
        GeoSubInfoPull = GeoSubInfoPull + "SubGeoCount = " & PshpSub.GeometryCount & Chr(13)
       
        ' If Geometry sections exist...
        If PshpSub.GeometryCount > 0 Then
       
            ' Get all Geometry sections one at a time.
            For Pgs = visSectionFirstComponent To (visSectionFirstComponent + PshpGrp.GeometryCount)
   
                ' Get all of the Rows in the current Geometry section.
                For Pgr = 0 To PshpSub.RowCount(Pgs) - 1
                   
                ' Currently I am only getting the Row Type, X and Y cells.
                GeoSubInfoPull = GeoSubInfoPull + "SubGeoRowType = " & _
                PshpSub.RowType(Pgs, Pgr) & Chr(13)
                GeoSubInfoPull = GeoSubInfoPull + "SubGeoCell-X = " & _
                PshpSub.CellsSRC(Pgs, Pgr, visX).ResultIU & Chr(13)
                GeoSubInfoPull = GeoSubInfoPull + "SubGeoCell-Y = " & _
                PshpSub.CellsSRC(Pgs, Pgr, visY).ResultIU & Chr(13)
                   
                Next Pgr
               
            Next Pgs
       
        End If
       
        ' If there are sub Shapes in the current group...
        If PshpSub.Shapes.Count > 0 Then
           
            ' Process them through the GeoSubInfoPull() Private Funcion.
            '   (Being a private function this can be done as deep as is needed)
            GeoSubInfoPull = GeoSubInfoPull + GeoSubInfoPull(PshpSub)
        End If

    Next PshpSub

End Function


[Jumpy]

Shape.Cells("Width").Formula   or
Shape.Cells("Width").FormulaU

should give you the formulas in the cells for your string

[MMZ_TimeLord]

Jumpy,

That's actually about where I started. But I needed to get the Geometry sections parsed and stored.

Now I have that completely done. At this point I'm writing routines for each of the Geometry sections as they are parsed to turn them into data that I can use to build a custom file format for export.

Here's what I have... minus the custom file export data.

Code Select Expand

    '
    '
    ' Pulls Geometry data from all selected shapes and sub-shapes
    '      and creates a custom Export File
    '
    '              Created by MMZ_TimeLord
    '                Version 0.5  2010-03-09
    '
   
    Public ExportFile As String  'String to hold Export File data
   

Sub GeoPullTest()

    Dim shpGrp As Visio.Shape   'Shape holder for this macro
    Dim GeoInfo As String       'String to save the resulting data
    Dim gs As Integer           'Counter for Geometry sections
    Dim gr As Integer           'Counter for Geometry section Rows
   
    ' Build the Export File header.
    ExportFile = "<ExportFileHeader>" & Chr(13)
   
    ' Operate on all shapes that are currently selected:
    For Each shpGrp In ActiveWindow.Selection
       
        ' If Geometry sections exist...
        If shpGrp.GeometryCount > 0 Then
       
            ' Get all Geometry sections one at a time.
            For gs = visSectionFirstComponent To (visSectionFirstComponent + shpGrp.GeometryCount)
   
                ' Clear GeoInfo
                GeoInfo = ""
               
                ' Add ExportSection header
                ExportFile = ExportFile + "<Export>" & Chr(13)
               
                ' Get all of the Rows in the current Geometry section.
                For gr = 0 To shpGrp.RowCount(gs) - 1
                   
                    ' Collect data for each cell by Row type through a private function.
                    GeoInfo = GeoInfo + GeoDataCollection(shpGrp, gs, gr)
                   
                Next gr
               
                ' Process GeoInfo into Spline data.
                ExportFile = ExportFile & ProcGeo2Export(GeoInfo)
               
                 ' Add Export Section footer.
                ExportFile = ExportFile & "</Export>" & Chr(13)
               
            Next gs
       
        End If
       
        ' If there are sub Shapes in the current group...
        If shpGrp.Shapes.Count > 0 Then
           
            ' Process them through the GeoSubInfoPull() Private Funcion.
            GeoInfo = GeoInfo + GeoSubInfoPull(shpGrp)
        End If

    Next shpGrp
   
    ExportFile = ExportFile & "<ExportHeader>" & Chr(13)
   
    ' Dump the results for observation.
    Debug.Print ExportFile

End Sub

Private Function GeoSubInfoPull(ByRef PshpGrp As Visio.Shape) As String

    Dim PshpSub As Visio.Shape      'subShape holder for this macro
    Dim Pgs As Integer              'Counter for Geometry sections
    Dim Pgr As Integer              'Counter for Geometry section Rows
   
    ' Process all sub Shapes within the passed Shape.
    '   (no, it does not have to be a Shape collection)
    For Each PshpSub In PshpGrp.Shapes
   
        '// Get the current geometry section of the sub-shape:
        GeoSubInfoPull = GeoSubInfoPull + "SubGeoCount = " & PshpSub.GeometryCount & Chr(13)
       
        ' If Geometry sections exist...
        If PshpSub.GeometryCount > 0 Then
       
            ' Get all Geometry sections one at a time.
            For Pgs = visSectionFirstComponent To (visSectionFirstComponent + PshpGrp.GeometryCount)
               
                ' Clear GeoInfo
                GeoSubInfoPull = ""
               
                ' Add Export Section header
                ExportFile = ExportFile & "<Export>" & Chr(13)
               
                ' Get all of the Rows in the current Geometry section.
                For Pgr = 0 To PshpSub.RowCount(Pgs) - 1
                   
                    'Collect data for each cell through a private function
                    GeoSubInfoPull = GeoSubInfoPull + GeoDataCollection(PshpSub, Pgs, Pgr)
                   
                Next Pgr
               
                ' Process GeoInfo into Spline data.
                ExportFile = ExportFile & ProcGeo2Export(GeoSubInfoPull)
               
                 ' Add Export Section footer.
                ExportFile = ExportFile & "</Export>" & Chr(13)
               
            Next Pgs
       
        End If
       
        ' If there are sub Shapes in the current group...
        If PshpSub.Shapes.Count > 0 Then
           
            ' Process them through the GeoSubInfoPull() Private Funcion.
            '   (Being a private function this can be done as deep as is needed)
            GeoSubInfoPull = GeoSubInfoPull + GeoSubInfoPull(PshpSub)
        End If

    Next PshpSub

End Function

Private Function GeoDataCollection(ByRef PshpGrp As Visio.Shape, Pgs As Integer, Pgr As Integer) As String

'  Retrieve X and Y cells regardless of Row type.

' Retrieve cells based on Row type.
If PshpGrp.RowType(Pgs, Pgr) = 138 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = MoveTo (138)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 139 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = LineTo (139)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 140 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = ArcTo (140)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 141 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = InfiniteLine (141)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & ", B = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 3).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 143 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = Ellipse (143)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & ", B = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 3).ResultIU & ", C = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 4).ResultIU & ", D = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 5).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 144 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = EllipticalArcTo (144)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & ", B = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 3).ResultIU & ", C = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 4).ResultIU & ", D = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 5).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 193 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = PolylineTo (193)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & Chr(13)
ElseIf PshpGrp.RowType(Pgs, Pgr) = 195 Then
    GeoDataCollection = GeoDataCollection + "GeoRowType = NURBSTo (195)" & ", X = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 0).ResultIU & ", Y = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 1).ResultIU & ", A = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 2).ResultIU & ", B = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 3).ResultIU & ", C = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 4).ResultIU & ", D = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 5).ResultIU & ", E = " & _
    PshpGrp.CellsSRC(Pgs, Pgr, 6).ResultIU & Chr(13)
End If

End Function

Private Function ProcGeo2Export(GeoInfo As String) As String

ProcGeo2Spline = GeoInfo

End Function


Thanks again AndyW!!!