Display object coordinate

[fani1926]

Hi all,

 

I am new to AutoCAD VBA. I would like to create a form with a button and list box, once we click on the button, a msgbox is displayed to require user select one/more features/objects and click space bar to confrim. Then the coordinate of features will be displayed in the listbox.

 

My question is, how can I do the first part - get the features by mouse click/on screen selection?

 

Thanks everyone

[fixo]

• Open VBA editor
  
• Insert form
  
• Drop on form ListView "listView1" and 2 buttons "cmdSelect" and "cmdExit"
  
• Add this code:
  

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

 

~'J'~