How to retrive 3D coordinate information of any object from AutoCAD VBA

Hi,

Does any one knows how to retrive 3D coordinate information of any object from AutoCAD VBA.

Please watch following program in AutoCAD VBA:unsure:

----------------------------------------------------------------

Dim entity As AcadEntity,my3Dobj As Acad3DSolid

For Each entity In ThisDrawing.ModelSpace

MsgBox "entity.ObjectName = " & entity.ObjectName

If LCase(entity.ObjectName) = "acdb3dsolid" Then

MsgBox "found solid"

Set my3Dobj = entity

'my3Dobj.( I don't understand which method will show XYZ 'coordinates of my3Dobj object. Please help me

my3Dobj = Nothing

End If

Next

-----------------------------------------------------------------

As you may have already determined, VBA has limited access to the information stored within an Acad3dSolid. There are a few methods traditionally employed to deal with this situation but they generally require quite a bit of custom code.

What exactly are you trying to find out about the Solid?

Thanks SEANT for comment,

Can you pass information about custom code which can retrive coordinates of 3D lines and save it in an array. I had search it in google but can not found any help.

Here’s a fairly basic routine to select some lines and store the endpoints into an array. The routine will print the endpoints to a Message Box.

Option Explicit

Sub Lines2Points()
Dim intCode(0) As Integer
Dim varData(0) As Variant
Dim entLine As AcadLine
Dim intLineQuantity As Integer
Dim arrLineCoords() As Variant
Dim i As Integer
Dim strMsg As String

intCode(0) = 0
varData(0) = "LINE"
intLineQuantity = (SoSSS(intCode, varData) * 2) - 1
If intLineQuantity > -1 Then
  ReDim arrLineCoords(intLineQuantity)
  For Each entLine In ThisDrawing.SelectionSets.Item("TempSSet")
     arrLineCoords(i) = entLine.StartPoint
     arrLineCoords(i + 1) = entLine.EndPoint
     i = i + 2
  Next
  For i = 0 To intLineQuantity Step 2
        strMsg = strMsg & "Start: " & PointToString(arrLineCoords(i)) _
           & "  --  End: " & PointToString(arrLineCoords(i + 1)) & vbCr
  Next
  MsgBox strMsg
  
End If
End Sub


Function SoSSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
Dim objSSs As AcadSelectionSets
Dim objTempSS As AcadSelectionSet
Set objSSs = ThisDrawing.SelectionSets
For Each objTempSS In objSSs
  If objTempSS.Name = "TempSSet" Then
     objTempSS.Delete
     Exit For
  End If
Next
  Set objTempSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'pick selection set
  If IsMissing(grpCode) Then
     objTempSS.SelectOnScreen
  Else
     objTempSS.SelectOnScreen grpCode, dataVal
  End If
  SoSSS = objTempSS.Count
End Function

Public Function PointToString(varPt As Variant) As String
Dim retVal As String, i As Long
  For i = LBound(varPt) To UBound(varPt)
      varPt(i) = Round(varPt(i), 2)
      retVal = retVal & CStr(varPt(i)) & ","
  Next
  PointToString = Left(retVal, Len(retVal) - 1)
End Function