AutoCAD 2006 VBA程序参考之----实体分析:质量特性。

Public Sub TestMassProperties()
  Dim objEnt As Acad3DSolid
  Dim varPick As Variant
  Dim strMassProperties As String
  Dim varProperty As Variant
  Dim intI As Integer
  On Error Resume Next
  '' let user pick a solid
  With ThisDrawing.Utility
    .GetEntity objEnt, varPick, vbCr & "Pick a solid: "
    If Err Then
      MsgBox "That is not an Acad3DSolid"
      Exit Sub
    End If
  End With
  '' format mass properties
  With objEnt
    strMassProperties = "Volume: "
    strMassProperties = strMassProperties & vbCr & " " & .Volume
    strMassProperties = strMassProperties & vbCr & vbCr & _
    "Center Of Gravity: "
    For Each varProperty In .Centroid
      strMassProperties = strMassProperties & vbCr & " " & varProperty
    Next
    strMassProperties = strMassProperties & vbCr & vbCr & _
      "Moment Of Inertia: "
    For Each varProperty In .MomentOfInertia
      strMassProperties = strMassProperties & vbCr & " " & varProperty
    Next
    strMassProperties = strMassProperties & vbCr & vbCr & _
      "Product Of Inertia: "
    For Each varProperty In .ProductOfInertia
      strMassProperties = strMassProperties & vbCr & " " & varProperty
    Next
    strMassProperties = strMassProperties & vbCr & vbCr & "Principal Moments: "
    For Each varProperty In .PrincipalMoments
      strMassProperties = strMassProperties & vbCr & " " & varProperty
    Next
    strMassProperties = strMassProperties & vbCr & vbCr & "Radii Of Gyration: "
    For Each varProperty In .RadiiOfGyration
      strMassProperties = strMassProperties & vbCr & " " & varProperty
    Next
    strMassProperties = strMassProperties & vbCr & vbCr & "Principal Directions: "
    For intI = 0 To UBound(.PrincipalDirections) / 3
      strMassProperties = strMassProperties & vbCr & " (" & _
        .PrincipalDirections((intI - 1) * 3) & ", " & _
        .PrincipalDirections((intI - 1) * 3 + 1) & "," & _
        .PrincipalDirections((intI - 1) * 3 + 2) & ")"
    Next
  End With
  '' highlight entity
  objEnt.Highlight True
  objEnt.Update
  '' display properties
  MsgBox strMassProperties, , "Mass Properties"
  '' dehighlight entity
  objEnt.Highlight False
  objEnt.Update
End Sub