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
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 (https://stackoverflow.com/questions/76314570/macro-to-export-visio-text-box-texts-to-excel)
PS I am new to Visio VBA!
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.
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
Simple code modification finds "normal" text and field inserted text:
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
Quote from: wapperdude on May 24, 2023, 05:30:29 PM
Ungrouping shapes can be DISASTEROUS!!! Don't do it.
Wot he said!!! +100
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.
Quote from: cdfjdk on May 24, 2023, 03:08:41 PMThe complete macro is here: https://stackoverflow.com/questions/76314570/macro-to-export-visio-text-box-texts-to-excel (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
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 (https://github.com/Visio-Resources/Snippets-n-Libraries/blob/main/VBA%20Handle%20on%20shapes.md)
Quote from: wapperdude on May 24, 2023, 05:30:29 PM
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.
;)
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. 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.
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!
For a start:
Change;
For Each vsPage In vsDoc.Pages
Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
ShapesList ActivePage.Shapes, xlWS
Next vsPage
to:
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.
Not sure where this came from,
Quoteread 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. :o :o :o
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.
Thank you both so much!
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!
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.
Quote from: cdfjdk on May 25, 2023, 07:39:41 PM
"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.
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.
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
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
I am getting a "Microsoft Visual Basic for Applications: Error 13 - Type Mismatch" with code, can anyone help please?
Quote from: Paul Herber on May 25, 2023, 05:07:28 PM
For a start:
Change;
For Each vsPage In vsDoc.Pages
Set xlWS = xlWB.Sheets.Add(After:=xlWB.Worksheets(xlWB.Worksheets.Count))
ShapesList ActivePage.Shapes, xlWS
Next vsPage
to:
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.
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!
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
Quote from: Surrogate on July 03, 2023, 03:34:42 PM
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!
Quote from: LeighH on July 03, 2023, 03:49:26 PMIm not sure what you mean, new to this
I am sorry, I am Russian!
Quote from: LeighH on July 03, 2023, 03:49:26 PM
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
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
Dim xlApp As Object, xlWB As Object, xlWS As Object, vsApp As Object
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
Quote from: Surrogate on July 03, 2023, 03:57:54 PM
Quote from: LeighH on July 03, 2023, 03:49:26 PMIm not sure what you mean, new to this
I am sorry, I am Russian! Quote from: LeighH on July 03, 2023, 03:49:26 PM
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
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
Dim xlApp As Object, xlWB As Object, xlWS As Object, vsApp As Object
Please check these variables in Locals Window
ShapesList vsPage.Shapes, xlWS
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?
It seems the Excel declarations are still wrong. Below works
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.
Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs fine. Here's what I used:
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
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.
Quote from: Surrogate on July 03, 2023, 07:20:06 PM
Please check these variables in Locals Window
ShapesList vsPage.Shapes, xlWS
Updated Local Window running through code and get Runtime error 13: Type mismatch on: ShapesList vsPage.Shapes, xlWS
Quote from: wapperdude on July 04, 2023, 02:37:37 AM
Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs
Code runs at Excel's side!
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 >:(
Quote from: Surrogate on July 04, 2023, 08:40:02 AM
Quote from: wapperdude on July 04, 2023, 02:37:37 AM
Using the previously mentioned variable definitions, I tried a chopped version of your code and it runs
Code runs at Excel's side!
Quote from: LeighH on July 04, 2023, 08:54:56 AM
I am running code in Excel VBA with Visio document open.
Did you add reference to Visio Application in your VBA-project ?
Sub ShapesList(ByVal shps As Shapes, ByVal xlWS As Object)If 'Not" then Excel's Shape Object not equal as Visio's Shape Object!
Thanks for helping :-)
I believe I have, see attached. I am clueless as to why this is not working when its worked for others :-(
Quote from: Surrogate on July 04, 2023, 09:00:25 AM
Quote from: LeighH on July 04, 2023, 08:54:56 AM
I am running code in Excel VBA with Visio document open.
Did you add reference to Visio Application in your VBA-project ?
Sub ShapesList(ByVal shps As Shapes, ByVal xlWS As Object)
If 'Not" then Excel's Shape Object not equal as Visio's Shape Object!
Ah, you run the code in Excel. That explains the mystery. Excel also has "Shapes" but those are different kind of "Shapes". You need to change the function as following:
This:
Sub ShapesList(ByVal shps As Shapes, ByVal xlWS As Object)
Dim sh As Shape
Should be (note the "Visio." prefix before "Shapes" and "Shape". We want Visio shapes, not Excel shapes here):
Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Object)
Dim sh As Visio.Shape
IMHO Best way declare all variables types explicit!
Dim vsPage As Visio.Page
Dim vsDoc As Visio.Document
Dim XlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim vsApp As Visio.Application
And in this line too
Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Excel.Worksheet)
Thanks Nikolay and Surrogate, this has now worked :-)
I appreciate all the help :-)
Quote from: Nikolay on July 04, 2023, 09:26:46 AM
Ah, you run the code in Excel. That explains the mystery. Excel also has "Shapes" but those are different kind of "Shapes". You need to change the function as following:
This:
Sub ShapesList(ByVal shps As Shapes, ByVal xlWS As Object)
Dim sh As Shape
Should be (note the "Visio." prefix before "Shapes" and "Shape". We want Visio shapes, not Excel shapes here):
Sub ShapesList(ByVal shps As Visio.Shapes, ByVal xlWS As Object)
Dim sh As Visio.Shape
Quote from: Surrogate on July 04, 2023, 09:30:39 AM
IMHO Best way declare all variables types explicit!
This works only when early binding.
When late binding - that is the case when you need to make the code suitable for "any" Visio version - then a late binding is better suited and you would declare all foreign objects (the Visio ones) as objects. VBA then figures out by itself what type of object it is.
Down sides:
- no event handling from the foreign object - at least no obvious solutions.
- worse debugging - you can however make a switch - debug with early binding, then switch to late.
Early vs late binding:
The backward compatibility seems like more of a deployment/automation issue, and not something typically encountered. (How's that for a nervy statement? As one who has very small exposure bubble, there likely is a lot of naivety.). I did find 3 references. The first is more in-depth. The 2nd hits more at the local user scenario. The 3rd has nice summary.
https://learn.microsoft.com/en-us/previous-versions/office/troubleshoot/office-developer/binding-type-available-to-automation-clients (https://learn.microsoft.com/en-us/previous-versions/office/troubleshoot/office-developer/binding-type-available-to-automation-clients)
https://learn.microsoft.com/en-us/dotnet/visual-basic/programming-guide/language-features/early-late-binding/ (https://learn.microsoft.com/en-us/dotnet/visual-basic/programming-guide/language-features/early-late-binding/)
https://learn.microsoft.com/en-us/power-apps/developer/data-platform/org-service/early-bound-programming (https://learn.microsoft.com/en-us/power-apps/developer/data-platform/org-service/early-bound-programming)
...and I have NOT fully explored the 1st and 3rd. The 2nd covers my typical use cases, those being early binding. There are a lot of benefits to such, which speaks directly to how I use VBA.
I had to handle about 20 installations, where different Visio versions where installed. I had to walk to each one and set the right reference to Visio.
Since then I switched all my code to late binding (with the mentioned drawbacks). Now with Visio 365 and its continuous update feature that may not be necessary anymore.
Need to check it.
Ouch. Sounds like a nightmare.
With a script (.vbs, vbscript file) it is somewhat possible to have events:
runme.vbs
Sub AppEvents_ShapeAdded(sh) ' <<< prefix match
WScript.Echo sh.Name
End Sub
Set app = WScript.CreateObject("Visio.Application", "AppEvents_") ' <<<< here
Set doc = app.Documents.Add("")
doc.Pages.Item(1).DrawRectangle 1, 2, 3, 4
doc.SaveAs "C:\temp\foo.vsd"
@Nikolay,
So your snippet is pure VBA and you set a reference to WScript instead of Visio?
I will try it. I have the problem that I need to make modifications to my Visio file before the user closes it. You're trick could help.
It's not exactly VBA, it is a VB script (you can copy snippet code to notepad, then save the content to a file with ".vbs" extension and double-click to run it).
VBScript is a sub-set of VBA. But yes, it does not have any references, as far as I can tell. WScript is "windows scripting" built-in reference.
You can basically run it without Visio or any office application installed.
Now it's mostly replaced with PowerShell.
How would I use it from inside my Access VBA project?
You are right, there appears to be no way to do this in pure VBA :'(
The magic "WScript" is not available.
Hi guys, I am just back from a chat with Chat-GPT. I am overwhelmed.
Have a read, it's worthwhile.
https://chat.openai.com/share/8b2bac74-19ac-499b-a2be-a30f80e2955e
I'm retiring.
Quote from: Paul Herber on July 10, 2023, 10:45:42 AM
I'm retiring.
Well, you could be the one who types in Chapt-GPT's orders in the PC. ;)
Our end will be when the AI reads the needs from internet activities of the end-users and offering them pro-actively solutions to the problems they haven't even formulate yet.
"I've detected that you're spending a lot of time on a chart for your boss, would like to switch to a 'speech-to-drawing' version? (See below the pricing table)"
Quote from: Yacine on July 10, 2023, 11:24:24 AM
... the needs from internet activities of the end-users ...
Apparently there is a large segment of the internet that provides for these needs. Or so I've been told.
Very interesting... but...
1) this is somewhat off topic now, so that can hinder those searching for solution to original post
2) this new info is of sufficient merit to warrant its own, focused topic.
What do you think?
Sorry mr. W., that won't Happen again. 😆
@Yacine: No worries. It started as a BTW deviation, which often becomes a topic of its own merit. This is one of those. Considering the exponentially increasing interest in AI, it seems to me Visio Guy ought to add another category to the forum.
Quote from: wapperdude on July 10, 2023, 06:09:44 PM
@Yacine: No worries. It started as a BTW deviation, which often becomes a topic of its own merit. This is one of those. Considering the exponentially increasing interest in AI, it seems to me Visio Guy ought to add another category to the forum.
Last active here on 26th May.
Quote from: Yacine on July 10, 2023, 09:05:08 AM
Hi guys, I am just back from a chat with Chat-GPT. I am overwhelmed.
Have a read, it's worthwhile.
https://chat.openai.com/share/8b2bac74-19ac-499b-a2be-a30f80e2955e
Does the last solution really work? I have checked and VBA gives an error at the below line ("Object" is not allowed to have "WithEvents"). Maybe ChatGPT is simply hallucinating here?
I've seen before how it invents non-existing functions and non-working solutions... Maybe, there is still some room left for meatbags?
Private WithEvents visApp As Object ' Late-bound Visio Application objectQuote
You must declare WithEvents variables to be object variables so that they can accept class instances. However, you cannot declare them as Object. You must declare them as the specific class that can raise the events.
https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/modifiers/withevents
The text in bold assumes early binding is required in VBA
You're absolutely right. The conversation continues later on with many corrections. I'm now at a point where I gave up the late binding and trying early binding.
Hello all, I am using the vba below in Excel which works to a point but some data overwrites itself when importing and I am not getting all text.
See example below attached
Example : MB-103-92-B Imports then gets overwritten by IE-2000-8TC-G-E
I have attached VBA code also (note, this is runinng from Excel)
Any help would be greatly appreciated.
***Correction, some of the symbols it extracts the text but not all, any idea why?
You can copy/paste your code using the "#" formatting icon. That way, your code can be copied and executed as written. In addition, uploading simple Excel & Visio files would also help.
Finally, is there a reason to avoid early binding. Late binding, unless required, brings many debugging issues.and other complications.
Thanks for your reply :-)
Please see attached Excel Template and Visio document.
It is not pulling all text from Visio document and especially all the switch data "MB-******"
Thanks in advance for any help :-)
Can you upload just your code? Use the # icon to paste code directly.
Here you go, thanks :-)
Edit note by wapperdude: made this a code insert rather than a simple paste:
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
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.
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!!! :D But, it seems more efficient/natural. :o. 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.
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.
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.
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
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.
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?
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.
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
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!
Thanks, sorry for the late reply, been trying to deal with personal problems.
This works, I really do appreciate this Wapperdude :-)
Hope the non-technical stuff gets sorted out.