How to use VBA to extract the text from the shape in visio???

[bdarby86]

Code Select Expand


something like this as the final result

[code = vb]
Option Explicit


Private visPage As Visio.Page
Private visDoc As Visio.Document
Private strCurrPath As String
Private fileOut As String


Public Sub createTextList()

    Dim arrString() As String
    Dim strFile As String
    ' output file name
    strFile = "c:\testfile.txt"
    ' read the text field from each of the shapes and return an array
    arrString = cyclePageShapes(Application.ActivePage)
    ' write the text fields out to a file
    writeTextFile strFile, arrString


End Sub

' go get an array of text strings
Private Function cyclePageShapes(ByVal currPage As Visio.Page) _
    As String()

    On Error GoTo ErrHandler

    Dim visShape As Visio.Shape
    Dim arrString() As String
    ReDim arrString(currPage.Shapes.Count)
    Dim intX As Integer
    intX = 1
   
    For Each visShape In currPage.Shapes
        arrString(intX) = visShape.Text
        intX = intX + 1
    Next visShape
       
    cyclePageShapes = arrString
    Exit Function

ErrHandler:

    Debug.Print Err.Description
    cyclePageShapes = arrString
   
End Function


'****************************************************
' File methods
'****************************************************


Private Function folderExists(ByVal strFolderName As String) _
        As Boolean

    Dim blnReturn As Boolean
    blnReturn = False
    Dim FSO As Scripting.FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    blnReturn = FSO.folderExists(strFolderName)
    ' release the filesystemobject
    Set FSO = Nothing
   
    folderExists = blnReturn
   
End Function


Private Function fileExists(ByVal strFileName As String) _
        As Boolean

    Dim blnReturn As Boolean
    blnReturn = False
    Dim FSO As Scripting.FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    blnReturn = FSO.fileExists(strFileName)
    ' release the filesystemobject
    Set FSO = Nothing
   
    fileExists = blnReturn
   
End Function

'
' pass in the file name and an array of strings
'
Private Sub writeTextFile( _
    ByVal strFileName As String, _
    ByRef arrString() As String)
     
    Dim FSO As FileSystemObject
    Dim FSOtextfile As TextStream
    Dim intCt As Integer
    Dim strText As String
   
    Set FSO = New FileSystemObject
         ' opens  file in write mode
        Set FSOtextfile = FSO.OpenTextFile(strFileName, 2, True)
           
        For intCt = 1 To UBound(arrString)
            strText = arrString(intCt)
            FSOtextfile.WriteLine (strText)
        Next intCt
       
        FSOtextfile.Close
       
End Sub

'****************************************************
'
'****************************************************

Private Sub Document_DocumentOpened(ByVal Doc As IVDocument)
    Set visDoc = Doc
    strCurrPath = Doc.Path
    Set visPage = Application.ActivePage
End Sub



Al,

This is great!  What would the code be to loop this through every page in the visio document and save it as an Excel file instead?  If possible, I'd like to capture only the strings which start with "[".  This can occur multiple times within the same shape.  For example:

[XXX] Hello
[XXX] Goodbye

Can occur within the same shape, but I need to capture them in separate rows in the Excel file.  Can this be done?  Any assistance you can provide would be greatly appreciated.  Thank you in advance for your time!

Brannon

[aledlund]

perhaps you could share a drawing with one of those shapes as an example.
al

[bdarby86]

Al,

I have attached an example.  Also, after changing the strFile in the previous code to a .csv, it provides what I need for a single page.  How would I loop the same code through each page in the document?  Thanks for your help!

Brannon

[aledlund]

It's actually two trivial changes. We first change the called macro to peform the loop

Code Select Expand


Public Sub createTextList()

    Dim arrString() As String
    Dim strFile As String
    ' output file name
    strFile = "c:\testfile.txt"
   
    Dim visDoc As Visio.Document
    Set visDoc = Application.ActiveDocument
    Dim visPage As Visio.Page

    For Each visPage In visDoc.Pages
   
        ' read the text field from each of the shapes and return an array
        arrString = cyclePageShapes(visPage)
        ' write the text fields out to a file
        writeTextFile strFile, arrString

    Next visPage

End Sub



And then we change the write method from a single file create/write to an append operation similar to what was posted previously.

Code Select Expand


'
' pass in the file name and an array of strings
'
Private Sub writeTextFile( _
    ByVal strFileName As String, _
    ByRef arrString() As String)
     
    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    Dim FSOtextfile As TextStream
   
    If Not FSO.fileExists(strFileName) Then
        Set FSOtextfile = FSO.CreateTextFile(strFileName)
    End If

    ' since we may have more that one page do it as an append operation
    Set FSOtextfile = FSO.OpenTextFile(strFileName, ForAppending)

    Dim intCt As Integer
    Dim strText As String
   
    For intCt = 1 To UBound(arrString)
        strText = arrString(intCt)
        FSOtextfile.WriteLine (strText)
    Next intCt
       
    FSOtextfile.Close
       
End Sub


al

[bdarby86]

Al,

It writes most of the text, but then I get an "Invalid procedure call or argument" error at:

Code Select Expand

FSOtextfile.WriteLine (strText)

Seems to me like it's performing the procedure, then calling it an invalid procedure afterwards.  Any way to get rid of the error message?  Thanks again!

Brannon

[Jumpy]

Try it without the bracets ():

Code Select Expand

FSOtextfile.WriteLine strText

[bdarby86]

same issue...

[Jumpy]

When in debug mode, what is the value of strText at that time?

or watch it with msgbox

Code Select Expand


For intCt = 1 To UBound(arrString)
        strText = arrString(intCt)
        msgbox(strText)
        FSOtextfile.WriteLine (strText)
Next intCt


[aledlund]

try this instead, it works on my system with no failure

Code Select Expand


'
' pass in the file name and an array of strings
'
Private Sub writeTextFile( _
    ByVal strFileName As String, _
    ByRef arrString() As String)
     
     On Error GoTo ErrHandler
     
    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    Dim FSOtextfile As TextStream
   
    If Not FSO.fileExists(strFileName) Then
        FSO.CreateTextFile (strFileName)
    End If

    ' since we may have more that one page do it as an append operation
    Set FSOtextfile = FSO.OpenTextFile(strFileName, ForAppending)

    Dim intCt As Integer
    Dim strText As String
   
    For intCt = 1 To UBound(arrString)
        strText = arrString(intCt)
        FSOtextfile.WriteLine (strText)
    Next intCt
       
    FSOtextfile.Close
   
    ' clean up
    Set FSOtextfile = Nothing
    Set FSO = Nothing
   
    Exit Sub
   
ErrHandler:

    Debug.Print Err.Description
       
End Sub



al

[bdarby86]

Perfect!  Thanks again for all of your help!

Brannon

[bdarby86]

try this instead, it works on my system with no failure

Code Select Expand


'
' pass in the file name and an array of strings
'
Private Sub writeTextFile( _
    ByVal strFileName As String, _
    ByRef arrString() As String)
     
     On Error GoTo ErrHandler
     
    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    Dim FSOtextfile As TextStream
   
    If Not FSO.fileExists(strFileName) Then
        FSO.CreateTextFile (strFileName)
    End If

    ' since we may have more that one page do it as an append operation
    Set FSOtextfile = FSO.OpenTextFile(strFileName, ForAppending)

    Dim intCt As Integer
    Dim strText As String
   
    For intCt = 1 To UBound(arrString)
        strText = arrString(intCt)
        FSOtextfile.WriteLine (strText)
    Next intCt
       
    FSOtextfile.Close
   
    ' clean up
    Set FSOtextfile = Nothing
    Set FSO = Nothing
   
    Exit Sub
   
ErrHandler:

    Debug.Print Err.Description
       
End Sub



al

Al,

How would I add a prompt for the user to key in their own file name?  In the following example, I want to keep the C:\ and .csv constant, but have the user key in the [filename]:

C:\[filename].csv

Thanks in advance for your time!

Brannon

[aledlund]

You might check this out.

http://office.microsoft.com/en-us/visio-help/HV080354031.aspx

al

Code Select Expand


Public Sub createTextList()

    Dim arrString() As String
    Dim strFile As String
   
    strFile = InputBox(Prompt:="Enter File Name.", _
          Title:="Output File Name", Default:="c:\testfile.txt")
   
    Dim visDoc As Visio.Document
    Set visDoc = Application.ActiveDocument
    Dim visPage As Visio.Page

    For Each visPage In visDoc.Pages
   
        ' read the text field from each of the shapes and return an array
        arrString = cyclePageShapes(visPage)
        ' write the text fields out to a file
        writeTextFile strFile, arrString

    Next visPage
   
End Sub

[\code]

[bdarby86]

Al,

You are awesome!  Thanks so much!

Brannon

[Ramaraj]

Hello Guys,

Using the code which is posted on the portal and file is created but I no text is generated in the file. Am I missing something? Let me know.

Regards,
Ram

[Paul Herber]

Maybe the text in your shapes is stored within a sub-shape.