AutoCAD开发1---获取块属性

Private Sub CommandButton1_Click()

    Dim pEntity As AcadObject

    Dim pBlock As AcadBlockReference

    Dim pPolyline As AcadLWPolyline

    Dim pSlct As AcadSelectionSet

 

    '若 Entity 选择集存在，则删除选择集，删除后并添加

    For i = 0 To ThisDrawing.SelectionSets.Count - 1

        If ThisDrawing.SelectionSets.Item(i).Name = "Entity" Then

            Set pSlct = ThisDrawing.SelectionSets.Item(i)

            pSlct.Delete

        End If

    Next i

    Set pSlct = ThisDrawing.SelectionSets.Add("Entity")

   

    '隐藏窗体，并用 SelectOnScreen 方法选择

    UserForm1.Hide

    pSlct.SelectOnScreen

   

    '定义要获取的数据的类型和数据载体

    Dim pXDataType As Variant

    Dim pXDatavlaue As Variant

   

    '定义块的插入点，坐标存放数组

    Dim pInsertPt As Variant

    Dim pCoords As Variant

    Dim sCoor As String

    

    For Each pEntity In pSlct

   

        'Debug.Print pEntity.ObjectName

       

        If pEntity.ObjectName = "AcDbBlockReference" Then

           

            Set pBlock = pEntity

           

            pBlock.GetXData "SOUTH", pXDataType, pXDatavlaue

           

            pInsertPt = pBlock.InsertionPoint

           

            'Debug.Print pXDataType(0) & "," & pXDataType(1)

            'Debug.Print pXDatavlaue(1) & "," & pInsertPt(0) & "," & pInsertPt(1) & "," & pBlock.Linetype & "," & pBlock.LinetypeScale & "," & pBlock.Lineweight & "," & pBlock.HasAttributes & "," & pBlock.XScaleFactor & "," & pBlock.YScaleFactor&; "," & pBlock.ZScaleFactor

            'Debug.Print pBlock.Name & "," & pBlock.Layer

            'Debug.Print pBlock.ObjectID & "," & pBlock.Handle & "," & pXDatavlaue(1) & "," & pInsertPt(0) & "," & pInsertPt(1)

            'Debug.Print pBlock.Linetype & "," & pBlock.LinetypeScale & "," & pBlock.Lineweight

            'Debug.Print pBlock.XScaleFactor & "," & pBlock.YScaleFactor & "," & pBlock.ZScaleFactor

            'Debug.Print

           

            MsgBox "块  名:" & pBlock.Name & Chr(13) & "所在层:" & pBlock.Layer & Chr(13) & "编  码:" & pXDatavlaue(1) & Chr(13) & "坐  标:" & Format(pInsertPt(0), "0.0000") & "," & Format(pInsertPt(1), "0.0000")

           

        ElseIf pEntity.ObjectName = "AcDbPolyline" Then

           

            Set pPolyline = pEntity

            pPolyline.GetXData "SOUTH", pXDataType, pXDatavlaue

           

            pCoords = pPolyline.Coordinates

           

            'Debug.Print pXDatavlaue(1) & "," & pPolyline.ObjectID

           

 

            For j = 0 To UBound(pCoords)

                If j Mod 2 = 0 Then

                    'Debug.Print sCoor

                    sCoor = ""

                End If

                sCoor = sCoor & pCoords(j) & ","

            Next j

            Debug.Print

        End If

    Next pEntity

 

 

    pSlct.Delete

 

 

    'UserForm1.Show

 

End Sub