Exporting shape and sub-shape texts to Excel

[LeighH]

Here you go, thanks :-)
Edit note by wapperdude:  made this a code insert rather than a simple paste:

Code Select Expand


Sub ExportVisioTextsExcel2()


    Dim vsPage As Visio.Page
    Dim vsDoc As Visio.Document
    Dim XlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim vsApp As Object
    Dim FldPath As String
    Dim FldName As String
    Dim FileToOpen As Variant
    Dim wb As ThisWorkbook
    Dim ws As Worksheet
    Dim vsoShapes As Visio.Shapes
    Dim vsoShape As Visio.Shape
    Dim NetBlock As Visio.Shape
    Dim DiagramServices As Integer
    Dim shapeCount As Integer
    Dim i As Integer

    Application.ScreenUpdating = False
   
    Set XlApp = CreateObject("Excel.Application")
    FileToOpen = Application.GetOpenFilename(Title:="Select Visio Architecture file", filefilter:="Visio Files (*.vsd*),*vsd*")
    Set vsApp = CreateObject("Visio.Application")
    XlApp.Visible = True
    XlApp.WindowState = xlMaximized
   
    Set xlWB = XlApp.Workbooks.Add
   
    Set vsDoc = vsApp.Documents.Open(FileToOpen)
    FldPath = "C:\Users\Public\Documents\"


    For Each vsPage In vsDoc.Pages
   
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
        ShapesList vsPage.Shapes, xlWS
       
    Next vsPage
   
    xlWB.Sheets("Sheet1").Select
    xlWB.Sheets("Sheet1").Name = "Signalling Visio Calcs"
   
    Dim lRow As Long
    Dim sh As Worksheet
    Dim shArc As Worksheet
   
    Set shArc = xlWB.Worksheets("Signalling Visio Calcs")
    For Each sh In xlWB.Worksheets
        Select Case sh.Name
            Case Is <> "Signalling Visio Calcs"
                lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row
                sh.Range("c1:c500").Copy _
                    Destination:=shArc.Range("A" & lRow)
        End Select
    Next
    Set shArc = Nothing
    Set sh = Nothing

    If Dir(FldPath & "Visio Export2.xlsm") <> "" Then
        Kill FldPath & "Visio Export2.xlsm"
    End If
   

    Application.DisplayAlerts = False
    xlWB.SaveAs FldPath & "Visio Export2.xlsm", FileFormat:=52

    'xlWB.Close
    'XlApp.Quit
    'vsDoc.Saved = True
    'vsApp.Quit
   
    Application.ScreenUpdating = True
   
End Sub

Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Object)
   
    Dim sh As Visio.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


[LeighH]

Thanks for your assistance Wapperdude but this still doesn't work, its driving me mad hahahah

It is still overwriting on the text import and cannot see anything different in the code.

[wapperdude]

Oh.  That is still your code unmodified.  I merely changed how it was posted...using icon labeled "#" above where you make a post entry.  It makes copying very easy.

As to your problem.  The issue is the recursive algorithm.  When it calls itself, it resets the last row variable.  There are two steps to solve this.  1) add a 3rd entry to the listing macro so that you can pass current value into the list macro, and 2) declare (dim statement) globallly.  That way it is defined for all calls to it.

Attached is a working solution.  I took a couple of liberties with the code. 
>> First, I run it from Visio file.  Hey!  This is a Visio site!!!     But, it seems more efficient/natural.   . To run from Excel the steps seem forced.  That is, create an Excel file, add the macro to it, add the Visio reference library, open Visio file, then run macro.   However, you must add the Excel reference library to the Visio file.  When complete, either edit code, or manually save the populated Excel file.  Note that this method does default to include 3 blank worksheets.  (I just ignored this to get working code.)
>> Second, I changed to early binding.  This makes working with the code so much easier.  However, I tried to make it portable so that it ought to run from Excel.  There are some additions that are needed to properly reference things related to Visio:  opening Visio file, paths,  etc.

[wapperdude]

Update:  in previous post, correction...
Once the lRow is defined globally, it is NOT necessary to alter the listing macro to have a 3rd entry.  It is fine with just the two. 

[wapperdude]

For those who want just the code.  It runs from a Visio file.  The Visio file must have Excel Reference library installed for Excel VBA calls.

Code Select Expand


Dim lRow As Long        'These 4 Dim statements are global.  They are placed preceding any sub() code design
Dim XlApp As Object
Dim xlWbk As Excel.Workbook
Dim xlSh As Excel.Worksheet

Sub ExportVisioTextsExcel()

    Dim vPg As Visio.Page
    Dim docPath As String
       
    Set XlApp = CreateObject("Excel.Application")
    Set xlWbk = XlApp.Workbooks.Add
    XlApp.Visible = False
   
    docPath = ThisDocument.Path
    lRow = 1
   
    For Each vPg In ActiveDocument.Pages
        Set xlSh = xlWbk.Sheets.Add(After:=xlWbk.Worksheets(xlWbk.Worksheets.Count))
        lRow = xlSh.UsedRange.Rows.Count
        ShapesList vPg.Shapes, xlSh
    Next vPg

    XlApp.Visible = True

' Could add code here to save Excel file and gracefully close / exit macro.
   
End Sub
Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Excel.Worksheet)
   
    Dim vShp As Visio.Shape
       
    For Each vShp In shps
        If Not vShp.OneD And vShp.Shapes.Count = 0 Then
            If vShp.CharCount > 0 Then
                xlWS.Cells(lRow, 1).Value = vShp.ID
                xlWS.Cells(lRow, 2).Value = vShp.Name
                xlWS.Cells(lRow, 3).Value = vShp.Text
                lRow = lRow + 1
            End If
        End If
        ShapesList vShp.Shapes, xlWS
    Next vShp
End Sub




[LeighH]

Sorry for the delay in reply, family bereavment.

This still will not work for me, I am in Excel running this marco to open Visio file and import all text to Excel and close visio.

Thanks for all your help, its very much appreciated.

[wapperdude]

Hmmm.  I guess I made an incorrect assumption.  That is, I assumed that you had edit rights to the Visio file, and inserting the code would not be an issue.  Thus, you are not allowed to touch/edit said file?  Even if the only editing is to insert the code and run it?

[wapperdude]

Here's modified code that runs from Excel.  It maintains the functionality of your original code.  Included in this version is a 3rd macro to do some Excel formatting to make it easier to read.  Easily commented out if not desired.  As previously noted, a 4th column was included to show shape parent.  This, likewise, is easily disabled.  There is very little "hard" coding with this version.

Code Select Expand


Dim lRow As Long                'These are global declarations; available all subs.
Dim XlApp As Object
Dim xlWbk As Excel.Workbook
Dim xlSH As Excel.Worksheet

Sub ExportVisioText2Excel()
'This macro resides in Excel.
'It allows user to pick a Visio file to recursi'vely extract shape text.
'It ignores 1-D shapes and shapes with no text.
'The text is placed one page at a time into a new Excel file.  Worksheet
'names match Visio page names.
'Some formating of the Excel file is provided.
'No data sorting as that code would have to be in the same (new) file as the data.
'To facilitate recursive algorithm, some variables must be globally declared.

    Dim vzApp As Object
    Dim vDoc As Visio.Document
    Dim vPg As Visio.Page
    Dim vDPath As String
    Dim docpath As String
   
    docpath = ThisWorkbook.Path
    Set vzApp = CreateObject("Visio.Application")
   
'Hunt for Visio file   
SelFile:
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Visio Files", "*.vsd, *.vsdx, *.vsdm"
        .InitialFileName = docpath
        .Show
        FileToOpen = .SelectedItems(1)
        Set vDoc = vzApp.Documents.Open(FileToOpen)
    End With

    Set XlApp = CreateObject("Excel.Application")
    Set xlWbk = XlApp.Workbooks.Add(xlWBATWorksheet)    'Creates new workbook with only 1 worksheet
    XlApp.Visible = False
       
    lRow = 1
   
'Loop thru all pages in Visio doc
    For Each vPg In vDoc.Pages
        Set xlSH = xlWbk.Sheets.Add(After:=xlWbk.Worksheets(xlWbk.Worksheets.Count))
        xlSH.Name = vPg.Name                            'Sets worksheet name = Visio page name
        lRow = xlSH.UsedRange.Rows.Count                'Sets/updates last variable
        ShapesList vPg.Shapes, xlSH                     'Recursive call
        formatXL xlSH                                   'Call worksheet formatting after populated
    Next vPg
   
    XlApp.Visible = True
    xlWbk.Worksheets("Sheet1").Delete                   'Gets rid of initial, blank 1st page.
   
'Code to save, close, and quit.   Beware if Excel file already exists.  May want code to check.
    xlWbk.SaveAs Filename:="enter name for new Excel file"    'Presently this is hard coded
   
'    XlApp.Quit                                          'Closes Excel app.  Will prompt if need to save or not
   
End Sub
Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Excel.Worksheet)
'Simplified code.  Added new 1st column for parent shape
   
    Dim vShp As Visio.Shape
    For Each vShp In shps
        If Not vShp.OneD And vShp.Shapes.Count = 0 Then 'Ignores 1D and groups
            If vShp.CharCount > 0 Then                  'Ignores shapes with no text
                xlWS.Cells(lRow, 1).Value = vShp.Parent            'This is new column
                xlWS.Cells(lRow, 2).Value = vShp.ID
                xlWS.Cells(lRow, 3).Value = vShp.Name
                xlWS.Cells(lRow, 4).Value = vShp.Text
                lRow = lRow + 1
            End If
        End If
        ShapesList vShp.Shapes, xlWS                    'This is recursive call
    Next vShp
End Sub

Sub formatXL(ByVal xlWS As Excel.Worksheet)
' BEGIN EXCEL FORMATTING STEPS.  All reference have been made explicit to eliminate multiple execution run errors introduced by VBA.

    Dim LastCol As Long                                  'These are only variables used in this sub.
    Dim LastRow As Long
    Dim p As Integer
    Dim q As Long
    Dim rowCell As Range
    Dim FirstRow As Range
    Dim myUsedRng As Range

    Set myUsedRng = xlWS.UsedRange
    Set FirstRow = myUsedRng.Rows(1).Cells              'This syntax seems to work!!!
       
    'Row and column index counters
        LastCol = myUsedRng.Columns.Count               'This is last populated column.
        LastRow = myUsedRng.Rows.Count                  'This is last populated row.
       
        With myUsedRng
         'Cell text alignment (center, middle)
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
       
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
       
         'Add light borders around all individual used cells
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
           
         'Heavy outer border around the used worksheet region
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeTop).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
           
         'Set used cell background fill
            .Interior.Color = RGB(245, 245, 245)
        End With
       
        'Insert new row for column header titles
        Rows(1).Insert Shift:=xlShiftDown
            xlWS.Cells(1, 1).Value = "Parent"
            xlWS.Cells(1, 2).Value = "ID"
            xlWS.Cells(1, 3).Value = "Name"
            xlWS.Cells(1, 4).Value = "Text"
           
            'Set top row upper case, font bold, cell background fill to light yellow, and set column widths
            For Each rowCell In FirstRow
                rowCell = UCase(rowCell)
                rowCell.Font.Bold = True
                rowCell.Font.Color = RGB(0, 0, 200)
                rowCell.Font.Size = 9
                rowCell.Interior.Color = RGB(255, 255, 204)
                rowCell.EntireColumn.AutoFit
            Next rowCell
                     
End Sub




[wapperdude]

Well, this was mostly self-indulgence.  It's been awhile since I've done much Excel coding. 

The attached Excel file is the culmination of this refresher.  It does what the "2nd OP" requested, namely, finds a Visio file, loads it, runs macro from within the Excel file, searches every page in the Visio file, every shape on each page, recursively, and grabs the text.  It ignores the 1D and shapes without text.  In the newly created Excel file, each worksheet corresponds to existing Visio page, bearing the same name.  After each page is finished, the user is prompted to choose to sort the data or not, and then on to the next page.  At the end, there is a residual blank 1st sheet that gets deleted.  Then, the user is prompted to Save or not.  Upon saving, Excel closes out.  The Visio file must be manually closed.  Note, whereever you place this attached file, that will be the starting directory and where the new Excel file is located.  Oh, one more note, the imported Excel data is formatted to be more readable.  Final note...on the quick access ribbon there is a button to launch the macro so you don't have to go hunting for it.

Spock:  "Fascinating."
Kirk:  ":It's been...fun"

Enjoy!

[LeighH]

Thanks, sorry for the late reply, been trying to deal with personal problems.
This works, I really do appreciate this Wapperdude :-)

[wapperdude]

Hope the non-technical stuff gets sorted out.