3dSolid长度。

Option Explicit
 'Bryco Swamp code 5-26-07
Sub DrawCylinderCenterlineLine(oCylinder As Acad3DSolid)
    Dim Xaxis(2) As Double, Yaxis(2) As Double, Zaxis(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 Ht As Double
    Dim Zero(2) As Double
    
    'Debug.Print vbAssoc(oCylinder, 1)
    
    Pd = oCylinder.PrincipalDirections
    For i = 0 To 2
        Xaxis(i) = Pd(i)
        Yaxis(i) = Pd(i + 3)
        Zaxis(i) = Pd(i + 6)
    Next i
    
    Set oUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "3d")
    oUcs.Origin = oCylinder.Centroid
    
    m = oUcs.GetUCSMatrix
    oCylinder.TransformBy (InverseMatrix(m))
    oCylinder.GetBoundingBox min, max
     
    Ht = (max(2) - min(2)) / 2
    StartPt = Zero
    StartPt(2) = StartPt(2) - Ht
    EndPt = Zero
    EndPt(2) = EndPt(2) + Ht
    Set oLine = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)
    oLine.TransformBy m
    oCylinder.TransformBy m
End Sub
Sub Test()
    Dim Ent As AcadEntity, V, C As Acad3DSolid
    ThisDrawing.Utility.GetEntity Ent, V, "Pick"
    If TypeOf Ent Is Acad3DSolid Then
        Set C = Ent
        DrawCylinderCenterlineLine C
    End If
End Sub
Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet)  0 Then
                pivot = Matrix(i, J)
                iP = J
                Exit For
            End If
        Next J
        For k = 0 To RowCt
            If Not k = i Then
                PC = Matrix(k, iP)
                If PC = 0 Then GoTo skip
                Sign = 1
                If pivot  0 Then
                        Sign = -1
                    End If
                End If
                
                Dim n1 As Double, n2 As Double
                n1 = Abs(pivot): n2 = Abs(PC)
                Den = LCD(n1, n2)
            
                For J = 0 To ColCt
                    dTemp = Matrix(k, J) * n1 / Den + (Matrix(i, J) * n2 / Den * Sign)
                    If Rd(dTemp, 0) Then
                        Matrix(k, J) = 0
                    Else
                        Matrix(k, J) = dTemp
                    End If
                Next J
            End If
skip:
        Next k
    Next i
    
    For i = 0 To RowCt
        For J = 0 To ColCt
            If Matrix(i, J)  0 Then
                pivot = 1 / Matrix(i, J)
                Exit For
            End If
        Next J
        For J = 0 To ColCt
            Matrix(i, J) = Matrix(i, J) * pivot
        Next J
    Next i
    
    MPivot = Matrix
    
End Function
Function OrderMatrix(Matrix As Variant) As Variant
    Dim i As Integer, J As Integer
    Dim k As Integer, l As Integer
    Dim RowCt As Integer, ColCt As Integer
    RowCt = UBound(Matrix, 1)
    ColCt = UBound(Matrix, 2)
    ReDim tempRow(ColCt) As Double
    'ij is row,column
    
    For i = 0 To RowCt
        For J = 0 To ColCt
            If J = i Then
                If Not Rd(Matrix(i, J), 1) Then
                    For k = 0 To RowCt
                        If Not k = i Then
                            If Rd(Matrix(k, J), 1) Then
                                For l = 0 To ColCt
                                    tempRow(l) = Matrix(k, l)
                                    Matrix(k, l) = Matrix(i, l)
                                    Matrix(i, l) = tempRow(l)
                                Next l
                            End If
                        End If
                    Next k
                End If
            End If
        Next J
    Next i
    OrderMatrix = Matrix
End Function
Function Transpose(Matrix As Variant) As Variant
    Dim iCnt As Integer, jCnt As Integer
    Dim transMat(0 To 3, 0 To 3) As Double
    Dim i As Integer, J As Integer
    iCnt = UBound(Matrix, 1)
    jCnt = UBound(Matrix, 2)
    For i = 0 To iCnt
        For J = 0 To jCnt
            transMat(i, J) = Matrix(J, i)
        Next J
    Next i
    Transpose = transMat
    
End Function
Function LCD(n1, n2) As Integer
    'LowestCommonDenominator
    Dim iCt As Integer, i As Integer
    Dim Ans As Integer
    Ans = 1
    If n1  1 Then
        For i = 1 To iCt
            If (n1 Mod i = 0 And n2 Mod i = 0) Then Ans = i
        Next i
    End If
    LCD = Ans
    
End Function

 '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 Then
            If Abs(Width - dp)  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