VBA学习笔记（7）-经典例子

例：VBA获取shape position

Public Sub LocationTable()
     'This routine will create a text file of the location and size of all 2-d shapes
     ' on the current page
    Dim shpObj     As Visio.Shape, celObj As Visio.Cell
    Dim ShpNo      As Integer, Tabchr     As String, localCent As Double
    Dim LocationX  As String, LocationY   As String
    Dim ShapeWidth As String, ShapeHeight As String
     
     'Open or create text file to write data
    Open "D:\LocationTable.txt" For Output Shared As #1
     
    Tabchr = Chr(9) 'Tab
     
     'Loop Shapes collection
    For ShpNo = 1 To Visio.ActivePage.Shapes.Count
                
        Set shpObj = Visio.ActivePage.Shapes(ShpNo)
        shapeCount = shpObj.Shapes.Count
        If shapeCount > 1 Then
          i = 1
          For i = 1 To shapeCount
              MsgBox vsoShape.Shapes(i).Text
          Next i
        Else
        If Not shpObj.OneD Then ' Only list the 2-D shapes
                'Get location Shape
               Set celObj = shpObj.Cells("pinx")
               'localCent = celObj.Result("mm")
               localCent = celObj.Result("inches")
            
            
               LocationX = Format(localCent, "000.0000")
               Set celObj = shpObj.Cells("piny")
               localCent = celObj.Result("inches")
               LocationY = Format(localCent, "000.0000")
             
                'Get Size Shape
               Set celObj = shpObj.Cells("width")
               localCent = celObj.Result("inches")
               ShapeWidth = Format(localCent, "000.0000")
               Set celObj = shpObj.Cells("height")
               localCent = celObj.Result("inches")
               ShapeHeight = Format(localCent, "000.0000")
             
               'Write values to Text file starting Name of Shape
               Print #1, shpObj.Name; shpObj.Text; Tabchr; _
               Tabchr; LocationX; Tabchr; LocationY; _
               Tabchr; ShapeWidth; Tabchr; ShapeHeight
        End If
         
    Next ShpNo
     'Close Textfile
    Close #1
     
     'Clean Up
    Set celObj = Nothing
    Set shpObj = Nothing
End Sub

经过修改，提取指定shape。

Option Explicit
Public Sub LocationTable()
     'This routine will create a text file of the location and size of all 2-d shapes
     ' on the current page
    Dim shpObj     As Visio.Shape, celObj As Visio.Cell
    Dim shpObj2    As Visio.Shape
    Dim ShpNo      As Integer, Tabchr     As String, localCent As Double
    Dim LocationX  As String, LocationY   As String
    Dim ShapeWidth As String, ShapeHeight As String
    Dim shapeCount As Integer
    Dim i As Integer
     'Open or create text file to write data
    Open "D:\LocationTable.txt" For Output Shared As #1
     
    Tabchr = Chr(9) 'Tab
     
     'Loop Shapes collection
    For ShpNo = 1 To Visio.ActivePage.Shapes.Count
        Set shpObj2 = Visio.ActivePage.Shapes(ShpNo)
        If Not shpObj2.OneD Then ' Only list the 2-D shapes
            shapeCount = shpObj2.Shapes.Count
            If shapeCount > 1 Then
                i = 1
                For i = 1 To shapeCount
                     Set shpObj = shpObj2.Shapes(i)
                     If (shpObj.CellsSRC(visSectionObject, visRowLine, visLinePattern) = 1) Then
                          'Get location Shape
                         Set celObj = shpObj.Cells("pinx")
                         'localCent = celObj.Result("mm")
                         localCent = celObj.Result("inches")
                         
                         LocationX = Format(localCent, "000.0000")
                         Set celObj = shpObj.Cells("piny")
                         localCent = celObj.Result("inches")
                         LocationY = Format(localCent, "000.0000")
                         
                          'Get Size Shape
                         Set celObj = shpObj.Cells("width")
                         localCent = celObj.Result("inches")
                         ShapeWidth = Format(localCent, "000.0000")
                         Set celObj = shpObj.Cells("height")
                         localCent = celObj.Result("inches")
                         ShapeHeight = Format(localCent, "000.0000")
                         
                         'Write values to Text file starting Name of Shape
                         Print #1, shpObj.Name; shpObj.Text; Tabchr; _
                         Tabchr; LocationX; Tabchr; LocationY; _
                         Tabchr; ShapeWidth; Tabchr; ShapeHeight
                     End If
                Next i
            Else
                Set shpObj = Visio.ActivePage.Shapes(ShpNo)
                If (shpObj.CellsSRC(visSectionObject, visRowLine, visLinePattern) = 1) Then
                   'MsgBox shpObj.CellsSRC(visSectionObject, visRowLine, visLinePattern)
                    'Get location Shape
                   Set celObj = shpObj.Cells("pinx")
                   'localCent = celObj.Result("mm")
                   localCent = celObj.Result("inches")
                
                   LocationX = Format(localCent, "000.0000")
                   Set celObj = shpObj.Cells("piny")
                   localCent = celObj.Result("inches")
                   LocationY = Format(localCent, "000.0000")
                 
                    'Get Size Shape
                   Set celObj = shpObj.Cells("width")
                   localCent = celObj.Result("inches")
                   ShapeWidth = Format(localCent, "000.0000")
                   Set celObj = shpObj.Cells("height")
                   localCent = celObj.Result("inches")
                   ShapeHeight = Format(localCent, "000.0000")
                 
                   'Write values to Text file starting Name of Shape
                   Print #1, shpObj.Name; shpObj.Text; Tabchr; _
                   Tabchr; LocationX; Tabchr; LocationY; _
                   Tabchr; ShapeWidth; Tabchr; ShapeHeight
               End If
            End If
        End If
         
    Next ShpNo
     'Close Textfile
    Close #1
     
     'Clean Up
    Set celObj = Nothing
    Set shpObj = Nothing
End Sub

 

REF: http://www.vbaexpress.com/kb/getarticle.php?kb_id=506