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

[Kshirsagar]

Hi,

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

Please watch following program in AutoCAD VBA
----------------------------------------------------------------

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


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

[SEANT]

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?

[Kshirsagar]

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.

[SEANT]

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