Mick it does seem like a losing battle, sure is interesting though. I was on a role until I found that the gi in moogoo doesn't mean a box but does mean any 4 sided object extruded.It seems that the PrincipalDirections start at the centroid and slice the object in half from that point. This makes sense of the dopey angles you sometimes get.

Luis, thanks but I don't think I'll take it that far.

I use solids,but not that often.

Here is an update for anyone interested.

` 'Bryco Swamp code 5-28-07`

Const pi As Double = 3.14159265358979

Sub DrawCylinderCenterlineLine(oCylinder As Acad3DSolid)

Dim Xaxis(2) As Double, Yaxis(2) As Double, Zaxis(2) As Double

Dim Zero(2) As Double

Dim Pd As Variant

Dim i As Integer

Dim min As Variant, max As Variant

Dim oUcs As AcadUCS

Dim m As Variant

Dim oLine As AcadLine

Dim StartPt As Variant, EndPt As Variant

Dim Width As Double, Depth As Double, Height As Double

Dim dp As Double, Rad As Double, Vol As Double

Dim sType As String

Dim sMessage As String

Dim sName As String

sName = vbAssoc(oCylinder, 1)

Debug.Print sName

sName = Mid(sName, 7, 2)

Debug.Print sName

Pd = oCylinder.PrincipalDirections

For i = 0 To 2

Xaxis(i) = Pd(i)

Yaxis(i) = Pd(i + 3)

Zaxis(i) = Pd(i + 6)

Next i

retry:

Set oUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "3d")

oUcs.Origin = oCylinder.Centroid

m = oUcs.GetUCSMatrix

oCylinder.TransformBy (InverseMatrix(m))

oCylinder.GetBoundingBox min, max

StartPt = Zero

EndPt = Zero

Depth = (max(2) - min(2))

dp = Depth / 2

StartPt(2) = StartPt(2) - dp

EndPt(2) = EndPt(2) + dp

Select Case sName

Case "gi"

sType = "Box"

Width = max(0) - min(0)

Height = max(1) - min(1)

'Vol = Width * Height * Depth

Vol = oCylinder.Volume

sMessage = "Type: box." & vbCrLf & "Width=" & Width _

& vbCrLf & "Height=" & Height & vbCrLf & "Depth=" & Depth _

& vbCrLf & "Volume=" & Vol

Case "kg"

sType = "extruded pline"

MsgBox "Type: extruded pline"

Case "kg"

sType = "non primitive"

sMessage = "This is not a primitive solid"

GoTo NonPrimitive

Case "i "

sType = "Sphere"

Rad = (max(0) - min(0)) / 2

Vol = pi * Rad * Rad * Rad * 4 / 3

sMessage = "Type: Sphere " & vbCrLf & "Rad=" & Rad & vbCrLf & "Volume=" & Vol

Case "mi" 'Ovaloids

Width = (max(0) - min(0)) / 2

Height = (max(1) - min(1)) / 2

If Abs(Width - Height) > 0.00000001 Then

'Here we are asking if height=width then it is a cylinder

'else it is an ellipse, with the extra check for

'messed up PrincipalDirections, if the height=depth.

If Abs(Width - dp) < 0.00000001 Or Abs(Height - dp) < 0.00000001 Then

Yaxis(0) = Zaxis(0): Yaxis(1) = Zaxis(1): Yaxis(2) = Zaxis(2)

oCylinder.TransformBy m

GoTo retry

End If

sType = "Ellipsoid"

Vol = pi * Width * Height * Depth

If Width < Height Then

Width = Height

Height = (max(0) - min(0)) / 2

End If

sMessage = "Type Ellipsoid " & vbCrLf & "Major radius=" & Width _

& vbCrLf & "Minor radius=" & Height _

& vbCrLf & "Depth=" & Depth & vbCrLf & "Volume=" & Vol

Else

sMessage = "Type Cylinder/ ovaloid"

Rad = Width

Vol = pi * (Rad * Rad) * dp * 2

sMessage = "Type Cylinder " & vbCrLf & "Radius=" & Width _

& vbCrLf & "Depth=" & Depth & vbCrLf & "Volume=" & Vol

End If

Case "mn"

sType = "Cone"

MsgBox "Type Cone"

dp = (max(2) - min(2)) / 4

StartPt(2) = StartPt(2) - dp

EndPt(2) = EndPt(2) + 3 * dp

sMessage = "Type Cone " & vbCrLf & "Radius=" & Width _

& vbCrLf & "Depth=" & Depth & vbCrLf & "Volume=" & Vol

Case "ln" 'Spherical segment

' sMessage = "Spherical Cap w/ non radial slice"

' GoTo NonPrimitiveCase "ni", "nf", "ln"

Vol = oCylinder.Volume

Case "ni", "nf" 'Partial sphere

'See Mathworld http://140.177.205.23/SphericalCap.html

sType = "Spherical Cap"

Width = (max(0) - min(0)) / 2

Height = (max(1) - min(1)) / 2

If Abs(Width - Height) > 0.00000001 Then

If Abs(Width - dp) < 0.00000001 Then

Yaxis(0) = Zaxis(0): Yaxis(1) = Zaxis(1): Yaxis(2) = Zaxis(2)

oCylinder.TransformBy m

GoTo retry

End If

End If

If Abs(Depth - Width) < 0.00000001 Then sType = "Hemisphere"

Dim baseRad As Double

If Depth > Width Then

'Cap is larger than a hemisphere so the width is the sphere's radius.

Rad = Width

baseRad = Sqr(Depth * (2 * Rad - Depth))

'Debug.Print "baseRad", baseRad, Depth, Rad

Else

baseRad = Width

Rad = ((baseRad * baseRad) + (Depth * Depth)) / (2 * Depth)

End If

Vol = (pi / 6) * ((3 * baseRad * baseRad) + (Depth * Depth)) * Depth

sMessage = "Type " & sType & vbCrLf & "Sphere's radius=" & Rad _

& vbCrLf & "Base radius=" & baseRad _

& vbCrLf & "Depth=" & Depth & vbCrLf & "Volume=" & Vol

dp = 3 * (2 * Rad - Depth) * ((2 * Rad) - Depth) / (4 * ((3 * Rad) - Depth))

StartPt(2) = (Rad - Depth) - dp

EndPt(2) = Rad - dp

Case Else

GoTo NonPrimitive

End Select

If Abs(Vol - oCylinder.Volume) > 0.00000001 Then

Yaxis(0) = Zaxis(0): Yaxis(1) = Zaxis(1): Yaxis(2) = Zaxis(2)

oCylinder.TransformBy m

GoTo retry

End If

NonPrimitive:

MsgBox sMessage

Set oLine = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)

oLine.TransformBy m

oCylinder.TransformBy m

End Sub

'SomeCallMeDave

'http://www.vbdesign.net/expresso/showthread.php?postid=83887#post83887

'Changed pAcadObj As AcadObject to pAcadObj As Object to access imagedef as well

'Modified by Jeff Mishler, March 2006, to get the Block table object, not Block_Record table object

Public Function vbAssoc(pAcadObj, pDXFCode As Integer) As Variant

Dim VLisp As Object

Dim VLispFunc As Object

Dim varRetVal As Variant

Dim obj1 As Object

Dim obj2 As Object

Dim strHnd As String

Dim strVer As String

Dim lngCount As Long

Dim i As Long

Dim J As Long

On Error GoTo vbAssocError

Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")

'Check your version ("VL.Application.1")

Set VLispFunc = VLisp.ActiveDocument.Functions

If Not TypeOf pAcadObj Is AcadBlock Then

strHnd = pAcadObj.Handle

Else

Dim lispStr As String

lispStr = "(cdr (assoc 5 (entget (tblobjname " & Chr(34) & "Block" & Chr(34) & Chr(34) & pAcadObj.Name & Chr(34) & "))))"

Set obj1 = VLispFunc.Item("read").Funcall(lispStr)

strHnd = VLispFunc.Item("eval").Funcall(obj1)

End If

Set obj1 = VLispFunc.Item("read").Funcall("pDXF")

varRetVal = VLispFunc.Item("set").Funcall(obj1, pDXFCode)

Set obj1 = VLispFunc.Item("read").Funcall("pHandle")

varRetVal = VLispFunc.Item("set").Funcall(obj1, strHnd)

Set obj1 = VLispFunc.Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")

varRetVal = VLispFunc.Item("eval").Funcall(obj1)

vbAssoc = varRetVal

'clean up the newly created LISP symbols

Set obj1 = VLispFunc.Item("read").Funcall("(setq pDXF nil)")

varRetVal = VLispFunc.Item("eval").Funcall(obj1)

Set obj1 = VLispFunc.Item("read").Funcall("(setq pHandle nil)")

varRetVal = VLispFunc.Item("eval").Funcall(obj1)

'release the objects or Autocad gets squirrely (no offense RR)

Set obj2 = Nothing

Set obj1 = Nothing

Set VLispFunc = Nothing

Set VLisp = Nothing

Exit Function

vbAssocError:

Set obj2 = Nothing

Set obj1 = Nothing

Set VLispFunc = Nothing

Set VLisp = Nothing

MsgBox "Error occurred " & Err.Description

End Function