Exporting shape and sub-shape texts to Excel

[cdfjdk]

I have been trying with only very minor success for over a day now to ungroup all shapes and subshapes so that I can export their Text. These text box texts can be exported by selecting Display Text in the Shape Report generator, so it would seem straightforward.

I have made numerous different attempts, the following being the best so far

Code

Dim vsDoc, vsPage As Object
Dim vsGroup As Visio.Shape    
Dim vsSelection As Visio.Selection

For Each vsPage In vsDoc.Pages

Set vsSelection = vsPage.CreateSelection(visSelTypeAll)
Set vsGroup = vsSelection.Group
vsGroup.Ungroup

Next vsPage

but this only ungroups the first shape in the first page. I can then get the Text from that subgroup, so the Text export part of my macro works. But how do I expand this to ungroup all subgroups in all pages?

After the Text is exported the Visio file is closed without saving, so any disruption to the shapes is not an issue.

The complete macro is here: https://stackoverflow.com/questions/76314570/macro-to-export-visio-text-box-texts-to-excel

PS I am new to Visio VBA!

[wapperdude]

Some questions...
>>  Are you calling this from Excel
>>  Is this part of a larger macro?

Comment:  Ungrouping shapes can be DISASTEROUS!!!  Don't do it.  Period.  It is not necessary.  To get text from group child members, and if those are groups, from their children, etc. etc.   The technique is recursive selection.  Here is adapted recursive code which excludes 1-D shapes from the output.  Also, the code does not find Field Inserted text.

Test file included.

Code

Sub Main()
' Code provided by Surrogate, adapted by Wapperdude
    ShapesList ActivePage.Shapes
End Sub

Sub ShapesList(ByVal shps As Shapes)
    Dim sh As Shape
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
            If Not sh.OneD Then       'Inside this "IF", place "listing functional code"
                Debug.Print sh.ID, sh.Name, sh.Text
            End If
        End If
        ShapesList sh.Shapes
    Next sh
End Sub

[wapperdude]

Simple code modification finds "normal" text and field inserted text:

Code

Sub Main()
' Code provided by Surrogate
    ShapesList ActivePage.Shapes
End Sub

Sub ShapesList(ByVal shps As Shapes)
    Dim sh As Shape
    Dim vChars As Visio.Characters
    
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
            If Not sh.OneD Then
                Set vChars = sh.Characters
                Debug.Print sh.ID, sh.Name, vChars
            End If
        End If
        ShapesList sh.Shapes
    Next sh
End Sub

[Paul Herber]

Ungrouping shapes can be DISASTEROUS!!!  Don't do it.

Wot he said!!! +100

[wapperdude]

Decided to look at your code.  Was this something that you generated?  Basically, it doesn't do anything.  First, it selects everything on 1st page.  Next, it creates a group for everything selected, and then, ungroups it.  Never gets to next page.

The issues with this code
  >> the selectall will never accomplish what you want it to.  It will not select any child shapes; kjust top level single shapes and group parent shapes.
  >> the group line should be deleted
  >> the ungroup could be changed to vsSelection.ungroup.  That does work.  But if there are additional groups, it needs to iterate again...and again until all groups are dissolved.  The For ... Next loop doesn't accommodate this.  It needs to be recursive.

[Surrogate]

The complete macro is here: https://stackoverflow.com/questions/76314570/macro-to-export-visio-text-box-texts-to-excel

I recommend that you add a link to this branch to your original post on the StackOverflow.

This may be useful to other users in the future years later

[Yacine]

Ungrouping every shape on a page - with or without condition - may be a legit task by its own, but doing it for getting the texts is certainly a very bad idea.
I happen to have written a collection of selection methods on github just a couple of days ago. You'll find there a way to iterate over every shape on a page, including the ones nested in arbitrary levels of grouping.
https://github.com/Visio-Resources/Snippets-n-Libraries/blob/main/VBA%20Handle%20on%20shapes.md

[hidden layer]

Ungrouping shapes can be DISASTEROUS!!! 

aah - it depends.
I often import schematics out of KiCAD. There are lots of "shapes" that are graphical expressions of some texts and there are (sometimes) on seperate layers. This is almost 60% of the whole import.
And all of them are grouped - often in further sub-groups.
But the goups doesn't have any functionality on its own.
That's why I can iteate the ungrouping command (with vba) as long there is no group existent anymore.
And after that deleting the unnecessary shapes.

In case of a Visio-shape (what is often a group with its own functionality (!)) you'll destroy this very one. That's the point.

[cdfjdk]

Many thanks for your help and my apologies for my amateur code. I have updated my code in Stackflow and added a link to this page and credited you with the solution. Please permit one further question - my updated code (also below) loops OK and populates a new XL sheet OK, but the exported data is identical in each sheet - i.e.

Code

For each page

is not working correctly.

In answer to other comments - while I have worked with VBA I have never worked with Visio VBA before and had read that CreateSelection(visSelTypeAll) would select all groups AND subgroups, enabling me to ungroup them ALL (and avoid the need for recursion) and then export the Shape.Text to Excel, which is my goal. As I would not be saving the Visio file, I did not see any problem with ungrouping everything.

Code

Sub ExportVisioTextsExcel()
 
    Dim vsPage As Visio.Page
    Dim vsDoc As Visio.Document
    Dim xlApp, xlWB, xlWS, vsApp As Object
    Dim FldPath As String

   
    Set xlApp = CreateObject("Excel.Application")
    Set vsApp = CreateObject("Visio.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    Set vsDoc = vsApp.Documents.Open("C:\xyz\File.vsdx")
    FldPath = "C:\xyz\"
 
    For Each vsPage In vsDoc.Pages
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
        ShapesList ActivePage.Shapes, xlWS
    Next vsPage
   
    xlWB.SaveAs FldPath & "xxx" & Format(Now(), "YYYYMMDD")
   
    MsgBox "Texts exported", vbInformation
   
End Sub
 
Sub ShapesList(ByVal shps As Shapes, ByVal xlWS As Object)
    Dim sh As Shape
    Dim vChars As Visio.Characters
    Dim lRow As Long
    lRow = xlWS.Cells(xlWS.Rows.Count, 1).End(xlUp).Row
   
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
            If Not sh.OneD Then
                Set vChars = sh.Characters
                xlWS.Cells(lRow, 1).Value = sh.ID
                xlWS.Cells(lRow, 2).Value = sh.Name
                xlWS.Cells(lRow, 3).Value = vChars.Text
            lRow = lRow + 1
            End If
        End If
        ShapesList sh.Shapes, xlWS
    Next sh
End Sub

Again many thanks!

[Paul Herber]

For a start:
Change;

Code

 For Each vsPage In vsDoc.Pages
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
        ShapesList ActivePage.Shapes, xlWS
    Next vsPage

to:

Code

 For Each vsPage In vsDoc.Pages
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
        ShapesList vsPage.Shapes, xlWS
    Next vsPage

and second, please stop thinking in terms of ungrouping.

[wapperdude]

Not sure where this came from,

read that CreateSelection(visSelTypeAll) would select all groups AND subgroups

.  But that is incorrect and sent you down the path to the dark side.  I did try to execute the code to select/group/ungroup.  It does NOT work as anticipated.

Here are links to the official descriptions:

https://learn.microsoft.com/en-us/office/vba/api/Visio.Page.CreateSelection
https://learn.microsoft.com/en-us/office/vba/api/Visio.visselectiontypes

Ocassionally, the web has misinformation.   

Regarding the grouping/ungrouping method.  There is one other concern not previously mentioned.  Ungrouping could lead to an excessive number of shapes on the page.  The hunt for text would have to examine each shape to see if there was text associated with it.  That would be a huge speed impact...in theory.

[cdfjdk]

Thank you both so much!

Code

 ShapesList vsPage.Shapes, xlWS

seems to have fixed it and I will do a thorough check of the output tomorrow and confirm - if as expected it's a fix maybe you would prefer to post the solution on Stackflow and get the rigthful kudos?
I have wondered about why the ungrouping would be so bad (I promise never to use the word again on this forum!), but "Ungrouping could lead to an excessive number of shapes on the page" explains that.
MANY thanks!

[cdfjdk]

Again all - many thanks, problem solved! I have changed the title of this thread to reflect it's real purpose and avoid the ungrouping issue.

[hidden layer]

"Ungrouping could lead to an excessive number of shapes on the page" explains that.

That's not the point (imho).
Because all shapes (grouped or ungrouped) are already there and grab their memory space.
The thing is the functionality of the group within its shapesheet.
Some shapesheet's (or code's) function influence a shape to do s'thing. In case of a group the function is present in the group only. Ungrouping destroys this functionality - relation to its sub-shapes as well to other shapes that only the group was interacting with.

[Paul Herber]

Whether the shapes are in groups or not is probably of no consequence to Visio. But, a shape within a group could have a text field that refers to the group shape or to another shape within the group. If the shape gets ungrouped then that text is gone.
Some people might say that Microsoft have a reputation for creating buggy code and security holes. Ungrouping shapes to get the text is right up there in that category.