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

[linkC]

I'm a newbie. I just want to use VBA to extract the text from the shape in visio,and output the content as *.csv.Could anybody help me ?

[aledlund]

Since 'text' is singular, and .csv infers multiples, maybe you might explain a little more of what you're trying to do.
al

[linkC]

Sorry,I come from a non-English speaking country,maybe I'm poor in English...
like this
I want to extract the content in the shape to a csv file
like 2.Chick in
     3.New?
     .......

[aledlund]

What I intended to say is that there is one field in a visio shape that is named "text", but there are many that may have 'text' in them. The most common fields that a user will ask for are the shape data fields. If you only want the "text" field then you will only have one item per line and do not need a CSV format (since your output will only have a single entry for each line).
Al

[cliff50]

from memory.. i think it may be something like...

Public sub Extract_Text ()
dim X as string
dim shp as shape

For each Shape in ActivePage.shapes

  set shp=Shape
  x=shp.text
  debug.print X

next shape

end sub

I might have some code somewhere to spit it out to a text file  or a excel spreadsheet I will see what I can find.

[linkC]

Oh~I realy hope you can find the code...thanks

[cliff50]

did you try that macro?.. did it print in the VBA immediate window what you
wanted ?

[linkC]

I tried your code in visio's Visual Basic Editor ,but nothing happened.

[aledlund]

It worked fine on my system. Was the immediate window set to display in the vba editor (as I remember it is off by default)? You can also set a breakpoint at the debug statement to check it.

I posted this reference over on your other query
http://msdn.microsoft.com/en-us/library/aa245244(v=office.10).aspx

al

[linkC]

Yeah，something wrong with my computer,now it's ok.

[linkC]

 How to save the "X" as a "*.txt"file???

[cliff50]

Public Function WriteX(ByVal X as string)
Dim fsObj As Scripting.FileSystemObject
Dim fs As Scripting.FileSystemObject

Set fs = CreateObject("Scripting.FileSystemObject")
Set fsObj = CreateObject("Scripting.FileSystemObject")

If Not fs.FileExists(ThisDocument.path & "List.txt") Then
createTextFile ("List.txt")
End If


Set A = fsObj.OpenTextFile(ThisDocument.path & "List.txt", ForAppending)
    A.Write X         
A.Close
End Function

call the WriteX function where you had the debug.print in the previous macro I posted.

[aledlund]

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



[aledlund]

don't forget to include the microsoft scripting runtime in your references (under tools in the vba editor)
al

[linkC]

Thank you