CADSharp

MACRO LIBRARY

Get extreme length of body

Free public access. No account or subscription required.

Files

Get extreme length of body Associated model

Code

Module: mMain

'Demonstrates how to use ExtremeLength class to get the extreme length of the selected body _
    in a direction determined by another entity that the user has selected.
    
'To use ExtremeLength, run Calculate function. This takes in two parameters. The first is _
    the body for which you want the extreme length and the second parameter must be a _
    straight edge, circular edge, cylindrical face, planar face, or reference plane.
    
'Notes:
'For a circular edge and cylindrical face, the axis is used. For planar face, reference _
    plane, and straight edge, the normal is used.
'The body specified in the first parameter of Calculate does not need to be parent of the _
    entity specified in the second parameter of Calculate.
    
'Preconditions for using the macro:
'   1. Body is selected in feature tree
'   2. Straight edge, circular edge, planar face, cylindrical face, or reference plane is selected
    
'Written by Keith Rice
'CADSharp LLC
'www.cadsharp.com
    
Option Explicit
    
Private Const SEL_ERR As String = "In order to run this macro you must pre-select two objects. " & _
    "The first object must be a body, selected from the FeatureManager design tree. " & _
    "The second object must be a straight edge, circular edge, planar face, cylindrical face, " & _
    "or reference plane."
    
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swBody As SldWorks.Body2
    Dim swObj As Object
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        swApp.SendMsgToUser "Please open a part or assembly."
        Exit Sub
    End If
    
    If swModel.GetType = swDocDRAWING Then
        swApp.SendMsgToUser "Please open a part or assembly."
        Exit Sub
    End If
    
    Set swSelMgr = swModel.SelectionManager
    
    If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Or _
        swSelMgr.GetSelectedObjectType3(1, -1) <> swSelSOLIDBODIES Then
        
        swApp.SendMsgToUser SEL_ERR
        Exit Sub
        
    End If
    
    Set swBody = swSelMgr.GetSelectedObject6(1, -1)
    Set swObj = swSelMgr.GetSelectedObject6(2, -1)
    
    If TypeOf swObj Is SldWorks.Feature Then
        Dim swfeat As SldWorks.Feature
        Set swfeat = swObj
        If Not TypeOf swfeat.GetSpecificFeature2 Is SldWorks.RefPlane Then
            swApp.SendMsgToUser SEL_ERR
            Exit Sub
        End If
    ElseIf Not TypeOf swObj Is SldWorks.Edge And Not TypeOf swObj Is SldWorks.Face2 And Not TypeOf swObj Is SldWorks.Feature Then
        swApp.SendMsgToUser SEL_ERR
        Exit Sub
    End If
    
    Dim myExtremeLength As New ExtremeLength
    myExtremeLength.Calculate swBody, swObj
    
    If IsEmpty(myExtremeLength.Direction) Then
        swApp.SendMsgToUser "Failed to get direction vector for selected object."
    Else
        If myExtremeLength.Length = -1 Then
            swApp.SendMsgToUser "Failed to get extreme length."
        Else
            If MsgBox("Extreme length (m): " & Round(myExtremeLength.Length, 6) & vbCrLf & vbCrLf & _
                "Would you like to sketch the line between the two extreme points discovered? " & _
                "(Note: This line does not necessarily represent the extreme length.)", vbYesNo) = vbYes Then
                
                SketchExtremePoints swModel, myExtremeLength.ExtremePoints
                
            End If
        End If
    End If
End Sub
    
Private Sub SketchExtremePoints(swModel As SldWorks.ModelDoc2, vPts)
    
    Dim swSketch As SldWorks.Sketch
    Set swSketch = swModel.SketchManager.ActiveSketch
    
    If swSketch Is Nothing Then
        swModel.SketchManager.Insert3DSketch Empty
        swModel.SketchManager.CreateLine vPts(0), vPts(1), vPts(2), vPts(3), vPts(4), vPts(5)
        swModel.SketchManager.Insert3DSketch Empty
    ElseIf swSketch.Is3D Then
        swModel.SketchManager.CreateLine vPts(0), vPts(1), vPts(2), vPts(3), vPts(4), vPts(5)
    Else
        swModel.SketchManager.InsertSketch Empty
        swModel.SketchManager.Insert3DSketch Empty
        swModel.SketchManager.CreateLine vPts(0), vPts(1), vPts(2), vPts(3), vPts(4), vPts(5)
        swModel.SketchManager.Insert3DSketch Empty
    End If
    
End Sub

Class: ExtremeLength

Option Explicit
    
Private extreme_points_backing As Variant
Private direction_backing As Variant
Private length_backing As Double
    
Private Enum EdgeGeom
    Straight
    Arc
    OtherEdgeType
End Enum
    
Private Enum FaceGeom
    planar
    cylindrical
    OtherFaceType
End Enum
    
Public Property Get ExtremePoints() As Variant
    ExtremePoints = extreme_points_backing
End Property
    
Public Property Get Direction() As Variant
    Direction = direction_backing
End Property
    
Public Property Get Length() As Double
    Length = length_backing
End Property
    
Public Sub Calculate(body As SldWorks.Body2, ent As Object)
    extreme_points_backing = Empty
    direction_backing = Empty
    length_backing = -1
    
    If ent Is Nothing Then Exit Sub
    
    If TypeOf ent Is SldWorks.Edge Then
        If ProcessEdge(ent, direction_backing) = False Then Exit Sub
    ElseIf TypeOf ent Is SldWorks.Face2 Then
        If ProcessFace(ent, direction_backing) = False Then Exit Sub
    ElseIf TypeOf ent Is SldWorks.Feature Then
        If ProcessFeat(ent, direction_backing) = False Then Exit Sub
    End If
    
    If IsEmpty(direction_backing) Then Exit Sub
    
    length_backing = GetExtremeLength(body, direction_backing, extreme_points_backing)
End Sub
    
Private Function ProcessEdge(swObj As Object, ByRef vDir As Variant) As Boolean
    ProcessEdge = True
    
    Dim swEdge As SldWorks.Edge
    
    Set swEdge = swObj
    
    If GetEdgeGeometry(swEdge) = Straight Then
        vDir = GetStraightEdgeDirVector(swEdge)
    ElseIf GetEdgeGeometry(swEdge) = Arc Then
        vDir = GetArcEdgeDirVector(swEdge)
    Else
        ProcessEdge = False
    End If
End Function
    
Private Function ProcessFace(swObj As Object, ByRef vDir As Variant) As Boolean
    ProcessFace = True
    
    Dim swFace As SldWorks.Face2
    
    Set swFace = swObj
    
    If GetFaceGeometry(swFace) = planar Then
        vDir = GetPlanarFaceDirVector(swFace)
    ElseIf GetFaceGeometry(swFace) = cylindrical Then
        vDir = GetCylFaceDirVector(swFace)
    Else
        ProcessFace = False
    End If
End Function
    
Private Function ProcessFeat(swObj As Object, ByRef vDir As Variant) As Boolean
    ProcessFeat = True
    
    Dim swfeat As SldWorks.Feature
    Dim swRefPlane As SldWorks.RefPlane
    
    Set swfeat = swObj
    
    If swfeat.GetTypeName = "RefPlane" Then
        Set swRefPlane = swfeat.GetSpecificFeature2
        vDir = GetRefPlaneDirVector(swRefPlane)
    Else
        ProcessFeat = False
    End If
End Function
    
Private Function GetEdgeGeometry(swEdge As SldWorks.Edge) As EdgeGeom
    Dim swCurve As SldWorks.Curve
    Set swCurve = swEdge.GetCurve
    
    If swCurve.IsLine Then
        GetEdgeGeometry = Straight
    ElseIf swCurve.IsCircle Then
        GetEdgeGeometry = Arc
    Else
        GetEdgeGeometry = OtherEdgeType
    End If
End Function
    
Private Function GetFaceGeometry(swFace As SldWorks.Face2) As FaceGeom
    Dim swSurf As SldWorks.Surface
    Set swSurf = swFace.GetSurface
    
    If swSurf.IsPlane Then
        GetFaceGeometry = planar
    ElseIf swSurf.IsCylinder Then
        GetFaceGeometry = cylindrical
    Else
        GetFaceGeometry = OtherFaceType
    End If
End Function
    
Private Function GetStraightEdgeDirVector(swEdge As SldWorks.Edge) As Variant
    Dim swCurve As SldWorks.Curve
    Set swCurve = swEdge.GetCurve
    GetStraightEdgeDirVector = Array(swCurve.LineParams(3), swCurve.LineParams(4), swCurve.LineParams(5))
End Function
    
Private Function GetArcEdgeDirVector(swEdge As SldWorks.Edge) As Variant
    Dim swCurve As SldWorks.Curve
    Set swCurve = swEdge.GetCurve
    GetArcEdgeDirVector = Array(swCurve.CircleParams(3), swCurve.CircleParams(4), swCurve.CircleParams(5))
End Function
    
Private Function GetPlanarFaceDirVector(swFace As SldWorks.Face2) As Variant
    GetPlanarFaceDirVector = swFace.Normal
End Function
    
Private Function GetCylFaceDirVector(swFace As SldWorks.Face2) As Variant
    Dim swSurf As SldWorks.Surface
    Set swSurf = swFace.GetSurface
    GetCylFaceDirVector = Array(swSurf.CylinderParams(3), swSurf.CylinderParams(4), swSurf.CylinderParams(5))
End Function
    
Private Function GetRefPlaneDirVector(swRefPlane As SldWorks.RefPlane) As Variant
    GetRefPlaneDirVector = Array(swRefPlane.GetRefPlaneParams(6), swRefPlane.GetRefPlaneParams(7), swRefPlane.GetRefPlaneParams(8))
End Function
    
Private Function GetExtremeLength(swBody As SldWorks.Body2, vDir As Variant, _
    ByRef vExtremePoints As Variant) As Double
    
    Dim dblExtremePts(5) As Double
    
    If swBody.GetExtremePoint(vDir(0), vDir(1), vDir(2), dblExtremePts(0), dblExtremePts(1), dblExtremePts(2)) = False Then
        'Failed to get extreme point in first direction
        GetExtremeLength = -1
        Exit Function
    End If
    
    If swBody.GetExtremePoint(-1 * vDir(0), -1 * vDir(1), -1 * vDir(2), dblExtremePts(3), dblExtremePts(4), dblExtremePts(5)) = False Then
        'Failed to get extreme point in second direction
        GetExtremeLength = -1
        Exit Function
    End If
    
    'See http://www.evernote.com/l/APC1pDtICBxDT5N-Bj6UHs36mPM3mo6sC_0/ for an
    '   explanation of the calculation below.
    Dim Length As Double
    Length = CalculateLength(dblExtremePts, vDir)
    
    vExtremePoints = dblExtremePts
    
    GetExtremeLength = Length
End Function
    
Private Function CalculateLength(vExtremePts, vDir As Variant) As Double
    Dim swApp As SldWorks.SldWorks
    Dim swMathUtil As SldWorks.MathUtility
    Dim swV1 As SldWorks.MathVector
    Dim swV2 As SldWorks.MathVector
    Dim swDir1 As SldWorks.MathVector
    Dim swDir2 As SldWorks.MathVector
    Dim swVHyp As SldWorks.MathVector
    Dim ptArr(2) As Double
    Dim dblDotProduct As Double
    
    Set swApp = Application.SldWorks
    Set swMathUtil = swApp.GetMathUtility
    
    ptArr(0) = vExtremePts(0)
    ptArr(1) = vExtremePts(1)
    ptArr(2) = vExtremePts(2)
    Set swV1 = swMathUtil.CreateVector(ptArr)
    
    ptArr(0) = vExtremePts(3)
    ptArr(1) = vExtremePts(4)
    ptArr(2) = vExtremePts(5)
    Set swV2 = swMathUtil.CreateVector(ptArr)
    
    ptArr(0) = vDir(0)
    ptArr(1) = vDir(1)
    ptArr(2) = vDir(2)
    Set swDir1 = swMathUtil.CreateVector(ptArr)
    
    Set swVHyp = swV1.Subtract(swV2)
    
    Set swDir2 = swVHyp.Normalise
    
    dblDotProduct = swDir2.Dot(swDir1)
    
    CalculateLength = Abs(swVHyp.GetLength * dblDotProduct)
End Function