ACAD2006VBA确定Acad3dSolid SolidType

Public Function IsSphereTorus(oObject As AcadObject) as boolean
    IsSphereTorus = false
    Dim oSphere As Acad3DSolid
    If TypeOf oObject Is Acad3DSolid Then
        Set oSphere = oObject 
        [color=green]If oSphere.SolidType = "Sphere" Or oSphere.SolidType = "Torus" Then[/color]
             IsSphereTorus = true
        End If
    End If
End Function 

bief54cxtjr.jpg

Option Explicit
Public Const AppName = "VBA | 3D Solid"
Public Sub Main()
    Dim Entity As AcadEntity
    Dim Point As Variant
    Dim objObject As Acad3DSolid
    On Error GoTo ErrMsg
    ThisDrawing.Utility.GetEntity Entity, Point, "Select a 3D Solid: "
    If TypeOf Entity Is Acad3DSolid Then
        Set objObject = Entity
        If IsSphereTorus(objObject) = True Then
            MsgBox "Type of entity: " & objObject.SolidType, vbExclamation + vbOKOnly, AppName
        Else
            MsgBox "FAIL!", vbExclamation + vbOKOnly, AppName
        End If
    End If
    Exit Sub
    
ErrMsg:
    If Err.Number = "-2147352567" Then
        MsgBox "You didn't pick anything.  Please try again.", vbExclamation + vbOKOnly, AppName
    Else
        MsgBox Err.Description & vbCrLf & Err.Number, vbCritical + vbOKOnly, AppName
        Debug.Print Err.Number
        Err.Clear
    End If
End Sub
Public Function IsSphereTorus(oObject As AcadObject) As Boolean
    IsSphereTorus = False
    Dim oSphere As Acad3DSolid
    If TypeOf oObject Is Acad3DSolid Then
        Set oSphere = oObject
        If oSphere.SolidType = "Sphere" Or oSphere.SolidType = "Torus" Then
             IsSphereTorus = True
        End If
    End If
End Function

Public Sub Test_SphereTorus()
    Set oAcadDoc = ThisDrawing
    Dim oEllipse As AcadEllipse
    Dim oEnt As AcadEntity
    Dim oSphere As Acad3DSolid
    Dim oPoint As Variant
    Set oEnt = oAcadDoc.ModelSpace.AddSphere(MakePoint(0, 0, 0), 5)
    Set oSphere = oEnt
    MsgBox IsSphereTorus(oSphere)
End Sub
Public Function MakePoint(ByVal X As Double, ByVal Y As Double, ByVal Z As Double)
    
    Dim dCoordinate(0 To 2) As Double
   
    dCoordinate(0) = X
    dCoordinate(1) = Y
    dCoordinate(2) = Z
    
    MakePoint = dCoordinate
End Function