[编程交流] 显示对象坐标

Option Explicit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' require Microsoft ListView Control version 6.0
' in Constructor window->right click on field->
' click "Additional controls", scroll down
' and check box for "Microsoft ListView Control version 6.0"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Private Sub UserForm_Initialize()
Me.Width = 272
ListView1.Width = 264
ListView1.ListItems.Clear
ListView1.Arrange = 0 'lvwAutoLeft
ListView1.View = 3 'lvwReport
ListView1.GridLines = True
' add columns
ListView1.ColumnHeaders.Add 1, "BlockName", "Block Name", 80, 0
ListView1.ColumnHeaders.Add 2, "X", "X", 60, 0
ListView1.ColumnHeaders.Add 3, "Y", "Y", 60, 0
ListView1.ColumnHeaders.Add 4, "Z", "Z", 60, 0
ListView1.FullRowSelect = True
End Sub
Private Sub cmdSelect_Click()
Dim oEnt As AcadEntity
Dim oblk As AcadBlockReference
 Dim itm As Object 'ListItem
 Dim oBlocks As AcadBlocks
 Dim oBlock As AcadBlock
 Dim oBlkRef As AcadBlockReference
 Dim ipt As Variant
 Dim fType(0) As Integer
 Dim fData(0) As Variant
 Dim oSset As AcadSelectionSet
 Dim iCount As Integer
 Dim dxfCode, dxfData
 Dim tmp(3)
 Dim blkColl As New Collection
 fType(0) = 0: fData(0) = "INSERT"
On Error GoTo Err_Trapp
For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$Blocks$" Then
oSset.Delete
Exit For
End If
Next oSset
Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$")
 dxfCode = fType
 dxfData = fData
 Me.Hide
 oSset.SelectOnScreen dxfCode, dxfData
 iCount = 0
 For Each oEnt In oSset
 Set oBlkRef = oEnt
 ipt = oBlkRef.InsertionPoint
   tmp(0) = oBlkRef.EffectiveName
   tmp(1) = ipt(0): tmp(2) = ipt(1): tmp(3) = ipt(2)
   blkColl.Add tmp
   Erase tmp
 Next oEnt
 oSset.Delete
 Set oSset = Nothing
 Dim i As Long, j As Long
 'populate array
 ReDim blkvar(blkColl.Count - 1, 1) As String
 For i = 1 To blkColl.Count
 blkvar(i - 1, 0) = blkColl.item(i)(0)
 blkvar(i - 1, 1) = blkColl.item(i)(1)
 Set itm = ListView1.ListItems.Add(1, , blkColl.item(i)(0))
 itm.SubItems(1) = Round(blkColl.item(i)(1), 3)
 itm.SubItems(2) = Round(blkColl.item(i)(2), 3)
 itm.SubItems(3) = Round(blkColl.item(i)(3), 3)
 Next
Me.Show
Err_Trapp:
End Sub
Private Sub ListView1_Click()
If ListView1.SelectedItem.Selected = True Then
Dim bname As String
bname = ListView1.SelectedItem.Text
Dim x As Double
x = CDbl(ListView1.SelectedItem.SubItems(1))
Dim y As Double
y = CDbl(ListView1.SelectedItem.SubItems(2))
Dim z As Double
z = CDbl(ListView1.SelectedItem.SubItems(3))
MsgBox "Block : " & vbCr & bname & vbCr & _
"Position: " & vbCr & "x = " & x & vbCr & "y = " & y & vbCr & "z = " & z
End If
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub