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