Exporting shape and sub-shape texts to Excel

[vojo]

could try the following
1 select the group
2 make sure behavior is set to group first then child ...or....child
3 delete all the shapes in the group not of interest....this becomes a group of 1 shape
4 resize the group size via update group "box"

This wont address 1 child using info from other child....or...go into the source shapesheet and
    set either the width and height  to 0 or 0.0001 or geometries to no show
But this would preserve a child using some group text or field

[LeighH]

Afternoon, I am using the script as shown below. When I run the code, I get "Microsoft Visual Basic for Applications - Type mismatch".  Can anyone please advise?

When I step through the code I get the error on this line of code:  ShapesList vsPage.Shapes, xlWS


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:\Users\z003j4kw\Desktop\Networks Design Templates\1a SDN Architecture Logical.vsdx")
    FldPath = "C:\Users\z003j4kw\Desktop\Networks Design Templates\"

    For Each vsPage In vsDoc.Pages
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
        ShapesList vsPage.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

[LeighH]

I am getting a "Microsoft Visual Basic for Applications: Error 13 - Type Mismatch" with code, can anyone help please?

For a start:
Change;

Code Select Expand


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 Select Expand


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.

[Surrogate]

Code Select Expand

Dim xlApp, xlWB, xlWS, vsApp As Object My opinion: you get this error because your variables xlApp, xlWB, xlWS is default type, not as Object!

[LeighH]

Thanks for you reply, Im not sure what you mean, new to this, I have XlApp, xlWB, xlWS, vsApp As Object as per the coding shown on this thread, am I doing something incorrect?

Dim XlApp, xlWB, xlWS, vsApp As Object

Thanks in advance
Leigh

Code Select Expand

Dim xlApp, xlWB, xlWS, vsApp As Object My opinion: you get this error because your variables xlApp, xlWB, xlWS is default type, not as Object!

[Surrogate]

Im not sure what you mean, new to this

I am sorry, I am Russian!

Thanks for you reply, Im not sure what you mean, new to this, I have XlApp, xlWB, xlWS, vsApp As Object as per the coding shown on this thread, am I doing something incorrect?

In VBA syntax when you type

Code Select Expand

Dim xlApp, xlWB, xlWS, vsApp As Object
' variables xlApp, xlWB, xlWS, vsApp have type: Variant
' variable vsApp have type: Object
My advice declare each variable explicitly ! Like as

Code Select Expand

Dim xlApp As Object, xlWB As Object, xlWS As Object, vsApp As Object


[LeighH]

Hi, thankyou for helping but Ive included full code below and still same error :-(

Microsoft Visual Basic for Applications - Type mismatch.

Sub ExportVisioTextsExcel()

    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

   
    Set XlApp = CreateObject("Excel.Application")
    Set vsApp = CreateObject("Visio.Application")
    XlApp.Visible = True
    Set xlWB = XlApp.Workbooks.Add
    Set vsDoc = vsApp.Documents.Open("C:\Desktop\Networks Design Templates\1a SDN Architecture Logical.vsdx")
    FldPath = "C:\Desktop\Networks Design Templates\"

    For Each vsPage In vsDoc.Pages
        Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.count))
        ShapesList vsPage.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

Im not sure what you mean, new to this

I am sorry, I am Russian!

Thanks for you reply, Im not sure what you mean, new to this, I have XlApp, xlWB, xlWS, vsApp As Object as per the coding shown on this thread, am I doing something incorrect?

In VBA syntax when you type

Code Select Expand

Dim xlApp, xlWB, xlWS, vsApp As Object
' variables xlApp, xlWB, xlWS, vsApp have type: Variant
' variable vsApp have type: Object
My advice declare each variable explicitly ! Like as

Code Select Expand

Dim xlApp As Object, xlWB As Object, xlWS As Object, vsApp As Object


[Surrogate]

Please check these variables in Locals Window

Code Select Expand

ShapesList vsPage.Shapes, xlWS

[Nikolay]

The code looks a bit odd. In which application do you run it? Do you run this VBA code fragment in Excel or in Visio? Or in some other application?

The top fragment is using "Visio.xxxx" that is not defined in Excel.
The bottom fragment is using "xlUp" constant that is not defined in Visio.

Then, it starts both applications anew (using "CreateObject"). Is this code really functional?

[wapperdude]

It seems the Excel declarations are still wrong.  Below works

Code Select Expand


Dim XlApp As Object
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet

Set XlApp = CreateObject("Excel.Application")
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets("Sheet1")


This assumes you're running the code from within Visio.

[wapperdude]

Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs fine.  Here's what I used:

Code Select Expand


Sub ExportVisioTextsExcel()

    Dim vsPage As Visio.Page
       
    Dim XlApp As Object
    Dim XlWrkbook As Excel.Workbook
    Dim XLSheet As Excel.Worksheet

    Set XlApp = CreateObject("Excel.Application")
    Set XlWrkbook = XlApp.Workbooks.Add
    Set XLSheet = XlWrkbook.Worksheets("Sheet1")

    For Each vsPage In ActiveDocument.Pages
        Set XLSheet = XlWrkbook.Sheets.Add(After:=XlWrkbook.Worksheets(XlWrkbook.Worksheets.Count))
        ShapesList vsPage.Shapes, XLSheet
    Next vsPage
End Sub
   
   
Sub ShapesList(ByVal shps As Shapes, ByVal XLSheet As Excel.Worksheet)
    Dim sh As Shape
    Dim vChars As Visio.Characters
    Dim lRow As Long
   
    lRow = XLSheet.Cells(XLSheet.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
                XLSheet.Cells(lRow, 1).Value = sh.ID
                XLSheet.Cells(lRow, 2).Value = sh.Name
                XLSheet.Cells(lRow, 3).Value = vChars.Text
            lRow = lRow + 1
            End If
        End If
        ShapesList sh.Shapes, XLSheet
    Next sh
End Sub


[LeighH]

Hello, here is my Local Windows view, I cannot see why it doesn't work but it does for others.

Here are the references I am using:
Visual Basic for Applications
Microsoft Excel 16.0 Object Library
OLE Automation
Microsoft Office 16.0 Object Library
Microsoft Visio 16.0 Object Library

I am trying to tun this code within Excel to open Visio file, extract text into Excel and close Visio file.

Please check these variables in Locals Window

Code Select Expand

ShapesList vsPage.Shapes, xlWS

[LeighH]

Updated Local Window running through code and get Runtime error 13: Type mismatch on:  ShapesList vsPage.Shapes, xlWS

[Surrogate]

Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs

Code runs at Excel's side!

[LeighH]

This does not work on mine, I get 'Class not registered' on 'For Each vsPage In ActiveDocument.Pages'.

I am running code in Excel VBA with Visio document open.

Am I missing some references?

I don't understand how this is working for most people but not me, arrrrrhhhhhhh

Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs

Code runs at Excel's side!