首页 > 编程语言 > 详细

VBA学习笔记(7)-经典例子

时间:2015-01-25 19:37:08      阅读:310      评论:0      收藏:0      [点我收藏+]

例: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

VBA学习笔记(7)-经典例子

原文:http://www.cnblogs.com/xiyoulhj/p/4248656.html

(0)
(0)
   
举报
评论 一句话评论(0
关于我们 - 联系我们 - 留言反馈 - 联系我们:wmxa8@hotmail.com
© 2014 bubuko.com 版权所有
打开技术之扣,分享程序人生!