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