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