Distance Mate Macro 8

[handleman]

I posted some quickie mate macros some time back for coincident, concentric, and parallel mates in thread559-175155. I'd been wanting to do a distance mate, but I liked the SW functionality that uses the current distance between the chosen components as the default distance. Calculating this distance turned out to be pretty involved, especially calculating normal distances (which was what the default SW mate function does) rather than just the shortest distance.

This macro, like the other macros, is faster than the standard way of adding mates (especially for larger assemblies) because it doesn't use the mate property manager and doesn't do a rebuild after adding each mate. It also saves mouse clicks by allowing you to enter a negative value for the dimension rather than having to check a box or click a button.

Hope it can be a help to others...

Const SF As Double = 1000  'scale factor.
'Change the scale factor value above based on your
'standard unit system.  Use:
'1000 for mm
'100/2.54 for inches



Sub main()
Dim CurDist As Double
Dim NewDist As Double
Dim CurFlip As Boolean
Dim NewFlip As Boolean
Dim cnt As Long
Dim myMateDim As SldWorks.Dimension
Dim InPutStr As String
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMate As SldWorks.Mate2
Dim ErrorLong As Long
Dim MsgReply As Integer
Dim NewAlign As Long
Dim sMsg As String
Dim sMateName As String

sMsg = "Enter desired mate distance" & vbCrLf & _
    "Enter a negative number to flip the dimension and change value." & vbCrLf & _
    "Enter ""-"" alone to flip current value shown" & _
    "To accept the current value, Cancel or press Enter"

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager



Const IBX As Integer = 2
Const IBY As Integer = 2



If swDoc.GetType <> swDocASSEMBLY Then
    MsgBox "Use this macro in Assembly documents only.", vbCritical
    Exit Sub
End If

If swSelMgr.GetSelectedObjectCount <> 2 Then
    MsgBox swSelMgr.GetSelectedObjectCount & " items selected.  Req'd number is 2.", vbCritical
    Exit Sub
End If

CurDist = GetInitialDist
If CurDist = -1 Then
    CurDist = 0
Else
    CurDist = CurDist
End If

Set swMate = swAssy.AddMate3(swMateDISTANCE, swMateAlignCLOSEST, True, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, False, ErrorLong)
sMateName = swMate.Name

If Nothing Is swMate Then
    MsgBox "Mating Error #" & ErrorLong & " Mate not added.", vbCritical
    Exit Sub
End If

'GoTo BYPASS

If swAddMateError_OverDefinedAssembly = ErrorLong Then
    MsgReply = MsgBox("Overdefining mate.  Keep anyway?", vbYesNo + vbQuestion)
    If vbNo = MsgReply Then
        swDoc.ClearSelection2 True
        swMate.Select True
        swDoc.Extension.DeleteSelection2 0
    Else
        'swDoc.EditRebuild3
    End If
ElseIf swMate.Alignment <> swMateAlignCLOSEST Then
    '''Verify alignment
    MsgReply = MsgBox("Keep current alignment?", vbYesNo, "Mate Alignment")
    
    If vbNo = MsgReply Then
        If swMate.Alignment = swMateAlignALIGNED Then
            NewAlign = swMateAlignANTI_ALIGNED
        Else
            NewAlign = swMateAlignALIGNED
        End If
        
        swMate.Select True
        swAssy.EditMate2 swMateDISTANCE, NewAlign, False, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, ErrorLong
        If swAddMateError_OverDefinedAssembly = ErrorLong Then
            MsgReply = MsgBox("Flip caused errors.  Undo?", vbYesNo + vbQuestion)
            If vbYes = MsgReply Then
                swDoc.EditUndo2 1
            End If
        End If
        'swDoc.EditRebuild3
    End If

    
ElseIf swAddMateError_NoError <> ErrorLong Then
    MsgBox "Mate error #" & ErrorLong & vbCrLf & "Mate not added"
    If Not swMate Is Nothing Then
        swDoc.ClearSelection2 True
        swMate.Select True
        swDoc.Extension.DeleteSelection2 0
    End If
ElseIf swMate.GetErrorCode <> swFeatureErrorNone Then
    Select Case swMate.GetErrorCode
        Case swFeatureErrorMateInvalidEdge
            MsgBox "Invalid edge"
        Case swFeatureErrorMateInvalidFace
            MsgBox "Invalid Face"
        Case swFeatureErrorMateFailedCreatingSurface
            MsgBox "Mate surface type not supported"
        Case swFeatureErrorMateInvalidEntity
            MsgBox "Supressed, Invalid, or Missing Entity"
        Case swFeatureErrorMateDanglingGeometry
            MsgBox "Mate geometry is dangling"
        Case swFeatureErrorMateEntityNotLinear
            MsgBox "Non-linear edges cannot be used for mating"
        Case swFeatureErrorMateOverdefined
            MsgBox "Mate is overdefining"
        Case swFeatureErrorMateIlldefined
            MsgBox "Mate cannot be solved (Ill-Defined)"
        Case swFeatureErrorMateBroken
            MsgBox "One or more entities suppressed or invalid for this mate"
    End Select
    swDoc.ClearSelection2 True
    swMate.Select True
    swDoc.Extension.DeleteSelection2 0
End If

''''''''Verify/Enter Distance
'get the mate dimension - if it is nonexistent then don't mess with it.
Dim genobj As SldWorks.Feature
Set genobj = swAssy.FeatureByName(sMateName)
Set swMate = genobj.GetSpecificFeature2
Set myMateDim = swMate.DisplayDimension.GetDimension

If Not myMateDim Is Nothing Then
    NewDist = Empty
    CurDist = CurDist * SF
    CurFlip = swMate.Flipped
    InPutStr = InputBox(sMsg, "Mate Distance", CurDist, 1, 1, Empty, Empty)
    If InPutStr = "" Then
        NewDist = CurDist
    ElseIf InPutStr = "-" Then
        NewDist = -CurDist
    Else
        NewDist = CDbl(InPutStr)
    End If
    If NewDist < 0 Then
        NewDist = 0 - NewDist
        If False = CurFlip Then
            NewFlip = True
        Else
            NewFlip = False
        End If
    Else
        NewFlip = CurFlip
    End If
    CurDist = CDbl(CurDist)
    cnt = 1

    While (Abs(NewDist - CurDist) > 0.00000001) Or CurFlip <> NewFlip
        'Debug.Print cnt, CurDist, CurFlip, NewDist, NewFlip
        If swSelMgr.GetSelectedObjectCount <> 3 Then
            'Debug.Print "select again", swSelMgr.GetSelectedObjectCount
            swMate.Select True
        End If
        swAssy.EditMate2 swMateDISTANCE, swMate.Alignment, NewFlip, NewDist / SF, NewDist / SF, NewDist / SF, 0, 0, 0, 0, 0, ErrorLong
        Set genobj = swAssy.FeatureByName(sMateName)
        Set swMate = genobj.GetSpecificFeature2
        Set myMateDim = swMate.DisplayDimension.GetDimension
        'myMateDim.SetValue3 NewDist, swSetValue_InAllConfigurations, Empty
        'swMate.Flipped = NewFlip
        'swDoc.EditRebuild3
        'If swAddMateError_OverDefinedAssembly = ErrorLong Then
        '    MsgReply = MsgBox("Distance change caused errors.  Undo?", vbYesNo + vbQuestion)
        '    If vbYes = MsgReply Then
        '        swDoc.EditUndo2 1
        '    End If
        'End If
        'swDoc.EditRebuild3
        CurDist = NewDist
        CurFlip = swMate.Flipped
        InPutStr = InputBox(sMsg, "Mate Distance", CurDist, 1, 1, Empty, Empty)
        If InPutStr = "" Then
            NewDist = CurDist
        ElseIf InPutStr = "-" Then
            NewDist = -CurDist
        Else
            NewDist = CDbl(InPutStr)
        End If
        If NewDist < 0 Then
            NewDist = 0 - NewDist
            If False = CurFlip Then
                NewFlip = True
            Else
                NewFlip = False
            End If
        Else
            NewFlip = CurFlip
        End If
        cnt = cnt + 1
    Wend
End If

swDoc.ClearSelection2 True
Set myMateDim = Nothing
Set swApp = Nothing
Set swDoc = Nothing
Set swAssy = Nothing
Set swSelMgr = Nothing
Set swMate = Nothing
End Sub

Private Function GetInitialDist()
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMathUtil As SldWorks.MathUtility
Dim myFace As SldWorks.Face2
Dim myFirstNormVect As SldWorks.MathVector
Dim mySecondNormVect As SldWorks.MathVector
Dim myFirstXform As SldWorks.MathTransform
Dim mySecondXform As SldWorks.MathTransform
Dim myDistVect As SldWorks.MathVector
Dim myDist As Double
Dim FirstDistPoint As Variant
Dim SecondDistPoint As Variant
Dim FirstDistVect As SldWorks.MathVector
Dim myModeler As SldWorks.Modeler
Dim mySel1 As Object
Dim mySel2 As Object
Dim myCross As SldWorks.MathVector
Dim FirstSelPlanar As Boolean
Dim SecondSelPlanar As Boolean

Dim tmpArrayData(2) As Double
Dim tmpPt As SldWorks.MathPoint

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swSelMgr = swDoc.SelectionManager
Set swMathUtil = swApp.GetMathUtility

''''''Check the first selection
If swSelMgr.GetSelectedObjectType3(1, -1) = 4 Then  'refplanes
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1).GetSpecificFeature
    FirstSelPlanar = True
    tmpArrayData(0) = 0
    tmpArrayData(1) = 0
    tmpArrayData(2) = 1
    Set tmpPt = swMathUtil.CreatePoint(tmpArrayData)
    Set myFirstXform = mySel1.Transform  'This gets the xfrom inside the component (not assy)
    Set tmpPt = tmpPt.MultiplyTransform(myFirstXform)
    Set myFirstNormVect = swMathUtil.CreateVector(tmpPt.ArrayData)
    'myFirstNormVect now contains the normal vector in part coords of the selected plane
ElseIf swSelMgr.GetSelectedObjectType3(1, -1) = 2 Then 'faces
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1)
    Set myFirstNormVect = swMathUtil.CreateVector(mySel1.Normal)
    If myFirstNormVect.GetLength <> 0 Then
        FirstSelPlanar = True
    Else
        FirstSelPlanar = False
    End If
Else
    FirstSelPlanar = False
    Set myFirstNormVect = Nothing
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1)
End If
    
'''''Check the second selection
If swSelMgr.GetSelectedObjectType3(2, -1) = 4 Then  'refplanes
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1).GetSpecificFeature
    SecondSelPlanar = True
    tmpArrayData(0) = 0
    tmpArrayData(1) = 0
    tmpArrayData(2) = 1
    Set tmpPt = swMathUtil.CreatePoint(tmpArrayData)
    Set mySecondXform = mySel2.Transform  'This gets the xfrom inside the component (not assy)
    Set tmpPt = tmpPt.MultiplyTransform(mySecondXform)
    Set mySecondNormVect = swMathUtil.CreateVector(tmpPt.ArrayData)
    'mysecondNormVect now contains the normal vector in part coords of the selected plane
ElseIf swSelMgr.GetSelectedObjectType3(2, -1) = 2 Then 'faces
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1)
    Set mySecondNormVect = swMathUtil.CreateVector(mySel2.Normal)
    If mySecondNormVect.GetLength <> 0 Then
        SecondSelPlanar = True
    Else
        SecondSelPlanar = False
    End If
Else
    SecondSelPlanar = False
    Set mySecondNormVect = Nothing
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1)
End If

'get the distance value and distance vector
myDist = swDoc.ClosestDistance(mySel1, mySel2, FirstDistPoint, SecondDistPoint)
Set FirstDistVect = swMathUtil.CreateVector(FirstDistPoint)
Set myDistVect = FirstDistVect.Subtract(swMathUtil.CreateVector(SecondDistPoint))

''''''Now get the in-assembly transforms for each component
Set myFirstXform = swSelMgr.GetSelectedObjectsComponent3(1, -1).GetTotalTransform(True)
Set mySecondXform = swSelMgr.GetSelectedObjectsComponent3(2, -1).GetTotalTransform(True)
If FirstSelPlanar And SecondSelPlanar Then
    Set myFirstNormVect = myFirstNormVect.MultiplyTransform(myFirstXform)
    Set mySecondNormVect = mySecondNormVect.MultiplyTransform(mySecondXform)
    Set myCross = myFirstNormVect.Cross(mySecondNormVect)
    If myCross.GetLength < 0.000000001 Then  'assume planes are parallel. Use par. dist
        myDist = Abs(myDistVect.Dot(myFirstNormVect.Normalise))
    Else
        'Leave myDist as-is
    End If
ElseIf FirstSelPlanar Then
    'Debug.Print "first planar"
    myDist = Abs(myDistVect.Dot(myFirstNormVect.Normalise))
ElseIf SecondSelPlanar Then
    'Debug.Print "second planar"
    myDist = Abs(myDistVect.Dot(mySecondNormVect.Normalise))
End If

'MsgBox myDist * SF
GetInitialDist = myDist
Set swApp = Nothing
Set swDoc = Nothing
Set swSelMgr = Nothing
Set swMathUtil = Nothing
Set myFace = Nothing
Set myFirstNormVect = Nothing
Set mySecondNormVect = Nothing
Set myFirstXform = Nothing
Set mySecondXform = Nothing
Set myDistVect = Nothing
Set FirstDistVect = Nothing
Set mySel1 = Nothing
Set mySel2 = Nothing
Set myCross = Nothing
Set tmpPt = Nothing

End Function

 

[CorBlimeyLimey]

Sounds good. I'll give it a whirl later.

 

[handleman]

OK, I had to fix a couple of things. The first thing is that I didn't include code to check whether the current position of components would require a flip or not. I added a bunch of code to check the component locations in both the flipped and un-flipped version (dimension flip, not alignment flip) of the mate and use the closer one. I also fixed problems with the distance calculating portion. When one of the mate entities was an assembly feature (planes, origin, etc) it caused an error.

I think it's all fixed now... It looks rather long, but it still runs fast.

Const SF As Double = 1000  'scale factor.
'Change the scale factor value above based on your
'standard unit system.  Use:
'1000 for mm
'100/2.54 for inches



Sub main()
Dim CurDist As Double
Dim NewDist As Double
Dim CurFlip As Boolean
Dim NewFlip As Boolean
Dim cnt As Long
Dim myMateDim As SldWorks.Dimension
Dim InPutStr As String
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMate As SldWorks.Mate2
Dim ErrorLong As Long
Dim MsgReply As Integer
Dim NewAlign As Long
Dim sMsg As String
Dim sMateName As String
Dim comp1Xform As SldWorks.MathTransform
Dim comp2Xform As SldWorks.MathTransform
Dim preMateVec1 As SldWorks.MathVector
Dim preMateVec2 As SldWorks.MathVector
Dim postMateVec1 As SldWorks.MathVector
Dim postMateVec2 As SldWorks.MathVector
Dim tVar As Variant
Dim Cross1Len As Double
Dim Cross2Len As Double
Dim UnFlippedCrossSum As Double
Dim FlippedCrossSum As Double
Dim genobj As SldWorks.Feature

sMsg = "Enter desired mate distance" & vbCrLf & _
    "Enter a negative number to flip the dimension and change value." & vbCrLf & _
    "Enter ""-"" alone to flip current value shown" & _
    "To accept the current value, Cancel or press Enter"

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager



Const IBX As Integer = 2
Const IBY As Integer = 2



If swDoc.GetType <> swDocASSEMBLY Then
    MsgBox "Use this macro in Assembly documents only.", vbCritical
    Exit Sub
End If

If swSelMgr.GetSelectedObjectCount <> 2 Then
    MsgBox swSelMgr.GetSelectedObjectCount & " items selected.  Req'd number is 2.", vbCritical
    Exit Sub
End If

CurDist = GetInitialDist(comp1Xform, comp2Xform)
If CurDist = -1 Then
    CurDist = 0
Else
    CurDist = CurDist
End If

If Not comp1Xform Is Nothing Then comp1Xform.GetData Nothing, Nothing, Nothing, preMateVec1, Empty
If Not comp2Xform Is Nothing Then comp2Xform.GetData Nothing, Nothing, Nothing, preMateVec2, Empty
Set swMate = swAssy.AddMate3(swMateDISTANCE, swMateAlignCLOSEST, False, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, False, ErrorLong)
If Nothing Is swMate Then
    MsgBox "Mating Error #" & ErrorLong & " Mate not added.", vbCritical
    Exit Sub
End If
sMateName = swMate.Name

'get the post-mate transforms of each component
If Not swSelMgr.GetSelectedObjectsComponent3(1, -1) Is Nothing Then
    Set comp1Xform = swSelMgr.GetSelectedObjectsComponent3(1, -1).GetTotalTransform(True)
    comp1Xform.GetData Nothing, Nothing, Nothing, postMateVec1, Empty
End If
If Not swSelMgr.GetSelectedObjectsComponent3(2, -1) Is Nothing Then
    Set comp2Xform = swSelMgr.GetSelectedObjectsComponent3(2, -1).GetTotalTransform(True)
    comp2Xform.GetData Nothing, Nothing, Nothing, postMateVec2, Empty
End If
'Get the sum of the magnitudes of the cross products of the vectors pre-and post-mate.
'If the pre-mate and post-mate vectors (from assy origin to component) are close to the
'same angle, their cross-product will be minimal.  The idea is to take the length of
'the pre- and post-mate cross products for both components for flipped and un-flipped.
'the minimum of these two is most likely the closest to the original location.
If (Not preMateVec1 Is Nothing) And (Not postMateVec1 Is Nothing) Then
    Cross1Len = preMateVec1.Cross(postMateVec1).GetLength
Else
    Cross1Len = 0
End If
If (Not preMateVec2 Is Nothing) And (Not postMateVec2 Is Nothing) Then
    Cross2Len = preMateVec2.Cross(postMateVec2).GetLength
Else
    Cross2Len = 0
End If

UnFlippedCrossSum = Cross1Len + Cross2Len
'swMate.Flipped = True
    
    If swSelMgr.GetSelectedObjectCount <> 3 Then
        'Debug.Print "select again", swSelMgr.GetSelectedObjectCount
        swMate.Select True
    End If
    swAssy.EditMate2 swMateDISTANCE, swMate.Alignment, True, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, ErrorLong
    Set genobj = swAssy.FeatureByName(sMateName)
    Set swMate = genobj.GetSpecificFeature2


If Not swSelMgr.GetSelectedObjectsComponent3(1, -1) Is Nothing Then
    Set comp1Xform = swSelMgr.GetSelectedObjectsComponent3(1, -1).GetTotalTransform(True)
    comp1Xform.GetData Nothing, Nothing, Nothing, postMateVec1, Empty
End If
If Not swSelMgr.GetSelectedObjectsComponent3(2, -1) Is Nothing Then
    Set comp2Xform = swSelMgr.GetSelectedObjectsComponent3(2, -1).GetTotalTransform(True)
    comp2Xform.GetData Nothing, Nothing, Nothing, postMateVec2, Empty
End If
If (Not preMateVec1 Is Nothing) And (Not postMateVec1 Is Nothing) Then
    Cross1Len = preMateVec1.Cross(postMateVec1).GetLength
Else
    Cross1Len = 0
End If
If (Not preMateVec2 Is Nothing) And (Not postMateVec2 Is Nothing) Then
    Cross2Len = preMateVec2.Cross(postMateVec2).GetLength
Else
    Cross2Len = 0
End If

FlippedCrossSum = Cross1Len + Cross2Len
'Debug.Print UnFlippedCrossSum, FlippedCrossSum
If UnFlippedCrossSum < FlippedCrossSum Then
    If swSelMgr.GetSelectedObjectCount <> 3 Then
        'Debug.Print "select again", swSelMgr.GetSelectedObjectCount
        swMate.Select True
    End If
    swAssy.EditMate2 swMateDISTANCE, swMate.Alignment, False, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, ErrorLong
    Set genobj = swAssy.FeatureByName(sMateName)
    Set swMate = genobj.GetSpecificFeature2
End If



'GoTo BYPASS

If swAddMateError_OverDefinedAssembly = ErrorLong Then
    MsgReply = MsgBox("Overdefining mate.  Keep anyway?", vbYesNo + vbQuestion)
    If vbNo = MsgReply Then
        swDoc.ClearSelection2 True
        swMate.Select True
        swDoc.Extension.DeleteSelection2 0
    Else
        'swDoc.EditRebuild3
    End If
ElseIf swMate.Alignment <> swMateAlignCLOSEST Then
    '''Verify alignment
    MsgReply = MsgBox("Keep current alignment?", vbYesNo, "Mate Alignment")
    
    If vbNo = MsgReply Then
        If swMate.Alignment = swMateAlignALIGNED Then
            NewAlign = swMateAlignANTI_ALIGNED
        Else
            NewAlign = swMateAlignALIGNED
        End If
        
        swMate.Select True
        swAssy.EditMate2 swMateDISTANCE, NewAlign, False, CurDist, CurDist, CurDist, 0, 0, 0, 0, 0, ErrorLong
        If swAddMateError_OverDefinedAssembly = ErrorLong Then
            MsgReply = MsgBox("Flip caused errors.  Undo?", vbYesNo + vbQuestion)
            If vbYes = MsgReply Then
                swDoc.EditUndo2 1
            End If
        End If
        'swDoc.EditRebuild3
    End If

    
ElseIf swAddMateError_NoError <> ErrorLong Then
    MsgBox "Mate error #" & ErrorLong & vbCrLf & "Mate not added"
    If Not swMate Is Nothing Then
        swDoc.ClearSelection2 True
        swMate.Select True
        swDoc.Extension.DeleteSelection2 0
    End If
ElseIf swMate.GetErrorCode <> swFeatureErrorNone Then
    Select Case swMate.GetErrorCode
        Case swFeatureErrorMateInvalidEdge
            MsgBox "Invalid edge"
        Case swFeatureErrorMateInvalidFace
            MsgBox "Invalid Face"
        Case swFeatureErrorMateFailedCreatingSurface
            MsgBox "Mate surface type not supported"
        Case swFeatureErrorMateInvalidEntity
            MsgBox "Supressed, Invalid, or Missing Entity"
        Case swFeatureErrorMateDanglingGeometry
            MsgBox "Mate geometry is dangling"
        Case swFeatureErrorMateEntityNotLinear
            MsgBox "Non-linear edges cannot be used for mating"
        Case swFeatureErrorMateOverdefined
            MsgBox "Mate is overdefining"
        Case swFeatureErrorMateIlldefined
            MsgBox "Mate cannot be solved (Ill-Defined)"
        Case swFeatureErrorMateBroken
            MsgBox "One or more entities suppressed or invalid for this mate"
    End Select
    swDoc.ClearSelection2 True
    swMate.Select True
    swDoc.Extension.DeleteSelection2 0
End If

''''''''Verify/Enter Distance
'get the mate dimension - if it is nonexistent then don't mess with it.

Set genobj = swAssy.FeatureByName(sMateName)

If Not genobj Is Nothing Then
    Set swMate = genobj.GetSpecificFeature2
    Set myMateDim = swMate.DisplayDimension.GetDimension
    NewDist = Empty
    CurDist = CurDist * SF
    CurFlip = swMate.Flipped
    InPutStr = InputBox(sMsg, "Mate Distance", CurDist, 1, 1, Empty, Empty)
    If InPutStr = "" Then
        NewDist = CurDist
    ElseIf InPutStr = "-" Then
        NewDist = -CurDist
    Else
        NewDist = CDbl(InPutStr)
    End If
    If NewDist < 0 Then
        NewDist = 0 - NewDist
        If False = CurFlip Then
            NewFlip = True
        Else
            NewFlip = False
        End If
    Else
        NewFlip = CurFlip
    End If
    CurDist = CDbl(CurDist)
    cnt = 1

    While (Abs(NewDist - CurDist) > 0.00000001) Or CurFlip <> NewFlip
        'Debug.Print cnt, CurDist, CurFlip, NewDist, NewFlip
        If swSelMgr.GetSelectedObjectCount <> 3 Then
            'Debug.Print "select again", swSelMgr.GetSelectedObjectCount
            swMate.Select True
        End If
        swAssy.EditMate2 swMateDISTANCE, swMate.Alignment, NewFlip, NewDist / SF, NewDist / SF, NewDist / SF, 0, 0, 0, 0, 0, ErrorLong
        Set genobj = swAssy.FeatureByName(sMateName)
        Set swMate = genobj.GetSpecificFeature2
        Set myMateDim = swMate.DisplayDimension.GetDimension
        'myMateDim.SetValue3 NewDist, swSetValue_InAllConfigurations, Empty
        'swMate.Flipped = NewFlip
        'swDoc.EditRebuild3
        'If swAddMateError_OverDefinedAssembly = ErrorLong Then
        '    MsgReply = MsgBox("Distance change caused errors.  Undo?", vbYesNo + vbQuestion)
        '    If vbYes = MsgReply Then
        '        swDoc.EditUndo2 1
        '    End If
        'End If
        'swDoc.EditRebuild3
        CurDist = NewDist
        CurFlip = swMate.Flipped
        InPutStr = InputBox(sMsg, "Mate Distance", CurDist, 1, 1, Empty, Empty)
        If InPutStr = "" Then
            NewDist = CurDist
        ElseIf InPutStr = "-" Then
            NewDist = -CurDist
        Else
            NewDist = CDbl(InPutStr)
        End If
        If NewDist < 0 Then
            NewDist = 0 - NewDist
            If False = CurFlip Then
                NewFlip = True
            Else
                NewFlip = False
            End If
        Else
            NewFlip = CurFlip
        End If
        cnt = cnt + 1
    Wend
End If

swDoc.ClearSelection2 True
Set myMateDim = Nothing
Set swApp = Nothing
Set swDoc = Nothing
Set swAssy = Nothing
Set swSelMgr = Nothing
Set swMate = Nothing
End Sub

Private Function GetInitialDist(ByRef c1Xform As SldWorks.MathTransform, ByRef c2Xform As SldWorks.MathTransform)
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMathUtil As SldWorks.MathUtility
Dim myFace As SldWorks.Face2
Dim myFirstNormVect As SldWorks.MathVector
Dim mySecondNormVect As SldWorks.MathVector
Dim myFirstXform As SldWorks.MathTransform
Dim mySecondXform As SldWorks.MathTransform
Dim myDistVect As SldWorks.MathVector
Dim myDist As Double
Dim FirstDistPoint As Variant
Dim SecondDistPoint As Variant
Dim FirstDistVect As SldWorks.MathVector
Dim myModeler As SldWorks.Modeler
Dim mySel1 As Object
Dim mySel2 As Object
Dim myCross As SldWorks.MathVector
Dim FirstSelPlanar As Boolean
Dim SecondSelPlanar As Boolean

Dim tmpArrayData(2) As Double
Dim tmpPt As SldWorks.MathPoint

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swSelMgr = swDoc.SelectionManager
Set swMathUtil = swApp.GetMathUtility

''''''Check the first selection
If swSelMgr.GetSelectedObjectType3(1, -1) = 4 Then  'refplanes
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1).GetSpecificFeature
    FirstSelPlanar = True
    tmpArrayData(0) = 0
    tmpArrayData(1) = 0
    tmpArrayData(2) = 1
    Set tmpPt = swMathUtil.CreatePoint(tmpArrayData)
    Set myFirstXform = mySel1.Transform  'This gets the xfrom inside the component (not assy)
    Set tmpPt = tmpPt.MultiplyTransform(myFirstXform)
    Set myFirstNormVect = swMathUtil.CreateVector(tmpPt.ArrayData)
    'myFirstNormVect now contains the normal vector in part coords of the selected plane
ElseIf swSelMgr.GetSelectedObjectType3(1, -1) = 2 Then 'faces
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1)
    Set myFirstNormVect = swMathUtil.CreateVector(mySel1.Normal)
    If myFirstNormVect.GetLength <> 0 Then
        FirstSelPlanar = True
    Else
        FirstSelPlanar = False
    End If
Else
    FirstSelPlanar = False
    Set myFirstNormVect = Nothing
    Set mySel1 = swSelMgr.GetSelectedObject6(1, -1)
End If
    
'''''Check the second selection
If swSelMgr.GetSelectedObjectType3(2, -1) = 4 Then  'refplanes
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1).GetSpecificFeature
    SecondSelPlanar = True
    tmpArrayData(0) = 0
    tmpArrayData(1) = 0
    tmpArrayData(2) = 1
    Set tmpPt = swMathUtil.CreatePoint(tmpArrayData)
    Set mySecondXform = mySel2.Transform  'This gets the xfrom inside the component (not assy)
    Set tmpPt = tmpPt.MultiplyTransform(mySecondXform)
    Set mySecondNormVect = swMathUtil.CreateVector(tmpPt.ArrayData)
    'mysecondNormVect now contains the normal vector in part coords of the selected plane
ElseIf swSelMgr.GetSelectedObjectType3(2, -1) = 2 Then 'faces
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1)
    Set mySecondNormVect = swMathUtil.CreateVector(mySel2.Normal)
    If mySecondNormVect.GetLength <> 0 Then
        SecondSelPlanar = True
    Else
        SecondSelPlanar = False
    End If
Else
    SecondSelPlanar = False
    Set mySecondNormVect = Nothing
    Set mySel2 = swSelMgr.GetSelectedObject6(2, -1)
End If

'get the distance value and distance vector
myDist = swDoc.ClosestDistance(mySel1, mySel2, FirstDistPoint, SecondDistPoint)
Set FirstDistVect = swMathUtil.CreateVector(FirstDistPoint)
Set myDistVect = FirstDistVect.Subtract(swMathUtil.CreateVector(SecondDistPoint))

''''''Now get the in-assembly transforms for each component
Dim i As Long
Debug.Print "rotation"
For i = 0 To 2
'Debug.Print myFirstXform.ArrayData(3 * i), myFirstXform.ArrayData(3 * i + 1), myFirstXform.ArrayData(3 * i + 2)
Next i
Debug.Print "xlation"
i = 3
'Debug.Print myFirstXform.ArrayData(3 * i), myFirstXform.ArrayData(3 * i + 1), myFirstXform.ArrayData(3 * i + 2)

If Not swSelMgr.GetSelectedObjectsComponent3(1, -1) Is Nothing Then
    Set myFirstXform = swSelMgr.GetSelectedObjectsComponent3(1, -1).GetTotalTransform(True)
    Set c1Xform = myFirstXform
ElseIf Not myFirstXform Is Nothing Then
    Set c1Xform = myFirstXform
End If

If Not swSelMgr.GetSelectedObjectsComponent3(2, -1) Is Nothing Then
    Set mySecondXform = swSelMgr.GetSelectedObjectsComponent3(2, -1).GetTotalTransform(True)
    Set c2Xform = mySecondXform
ElseIf Not mySecondXform Is Nothing Then
    Set c2Xform = mySecondXform
End If

If FirstSelPlanar And SecondSelPlanar Then
    Set myFirstNormVect = myFirstNormVect.MultiplyTransform(myFirstXform)
    Set mySecondNormVect = mySecondNormVect.MultiplyTransform(mySecondXform)
    Set myCross = myFirstNormVect.Cross(mySecondNormVect)
    If myCross.GetLength < 0.000000001 Then  'assume planes are parallel. Use par. dist
        myDist = Abs(myDistVect.Dot(myFirstNormVect.Normalise))
    Else
        'Leave myDist as-is
    End If
ElseIf FirstSelPlanar Then
    'Debug.Print "first planar"
    myDist = Abs(myDistVect.Dot(myFirstNormVect.Normalise))
ElseIf SecondSelPlanar Then
    'Debug.Print "second planar"
    myDist = Abs(myDistVect.Dot(mySecondNormVect.Normalise))
End If

'MsgBox myDist * sf
GetInitialDist = myDist
Set swApp = Nothing
Set swDoc = Nothing
Set swSelMgr = Nothing
Set swMathUtil = Nothing
Set myFace = Nothing
Set myFirstNormVect = Nothing
Set mySecondNormVect = Nothing
Set myFirstXform = Nothing
Set mySecondXform = Nothing
Set myDistVect = Nothing
Set FirstDistVect = Nothing
Set mySel1 = Nothing
Set mySel2 = Nothing
Set myCross = Nothing
Set tmpPt = Nothing

End Function

 

[CorBlimeyLimey]

WOW ... that makes for a long thread. Perhaps just posting a link for downloading the file would be better next time.

It works great, but just one small point. After creating the mate, you have to rebuild the assembly to have it show in the FM.

 

[handleman]

Thanks for the feedback! Sorry about the thread length. I just wonder about how long the link to engineering.com lasts. The lack of FM updating is a side effect of trying to absolutely minimize the time required to add mates, especially for larger assemblies since the default mating functions really start to bog down. I had experimented with including an EditRebuild3 statement to get the mates to show up immediately, but I felt that the delay it caused was too long as assembly size increased. However, you prompted me to look a bit further, and I found that there are four different "rebuild" type functions that will do the trick, each yielding different rebuild times. For a moderately sized assembly (642 comps, 33 top-level comps, 83 top-level mates) the amount of delay between final user interaction and macro completion was:

0.016s for no rebuild (current function - mates don't show up in tree)
0.332s for FeatureManager::UpdateFeatureTree (tree updates, but no geom. rebuilding)
0.379s for ModelDoc2::Rebuild with the swUpdateMates option (mates added to tree, mate geom. rebuilt if needed)
0.863s for EditRebuild3 (full, non-Ctrl-Q, rebuild)

0.86 seconds was unacceptable to me, but 0.332 is probably reasonable.
The way the rest of the macro works, UpdateFeatureTree would probably be all that is needed. If you want to add that in, just put the line

swDoc.FeatureManager.UpdateFeatureTree

at the end of the main() subroutine, right after the line "swDoc.ClearSelection2 True" and immediately before all of the "Set Xxxx = Nothing" lines. If you use the other three macros and want to add that line to those, it would also go right at the end just after the "swDoc.ClearSelection2 True" line.

 

[fcsuper]

For a forum, listing the code is usually better than providing a link because there are some issues with SolidWorks sometimes not being able to identify reference libraries for .swp's created on other systems. This doesn't work well for macros with forms of course. But if no forms are used, I prefer the listing method.

Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
sw.fcsuper.com
Co-moderator of Solidworks Yahoo! Group

 

[handleman]

One more change to improve functionality....

There are two places in the macro where the line:

NewDist = CDbl(InPutStr)

occurs. I was using the macro and (unthinkingly) tried to enter a mathematical expression rather than a straight number. Obviously, that failed. But I found the undocumented function "Evaluate". From what I can gather, it evaluates its argument as though it were a line of VBA code. Long story short, replace the line above with

NewDist = CDbl(Evaluate(InPutStr, True, False))

and you can enter any expression that is evaluatable in VBA. 362-69, 20+cos(1.970), whatever you want that can be evaluated to a number.

 

[brengine]

And something so you don't have to manually tell the macro whether you're using mm or inch...

If (swDoc.GetUserPreferenceIntegerValue(swUnitsLinear) = swMM) Then
    SF = 1000 'scale factor: meters -to- mm
ElseIf (swDoc.GetUserPreferenceIntegerValue(swUnitsLinear) = swINCHES) Then
    SF = 1000 / 25.4 'scale factor: meters -to- inches
Else
    MsgBox "Use this macro for Assembly documents with mm or inch units only.", vbCritical, "Distance Mate Macro"
    Exit Sub
End If

 

[handleman]

OK, one more. Maybe. If you add

        InPutStr = Replace(InPutStr, """", "*" & SF / (100 / 2.54), 1, -1, vbTextCompare)
        InPutStr = Replace(InPutStr, "'", "*" & SF / (100 / 30.48), 1, -1, vbTextCompare)
        InPutStr = Replace(InPutStr, "mm", "*" & SF / 1000, 1, -1, vbTextCompare)
        InPutStr = Replace(InPutStr, "cm", "*" & SF / 100, 1, -1, vbTextCompare)
        InPutStr = Replace(InPutStr, "m", "*" & SF, 1, -1, vbTextCompare)

immediately above the two lines with "Evaluate" then you can enter values in designated units, regardless of your current document units setting, as long as you either set up the SF constant correctly or add Ken's code above (Thanks, Ken!). Any number without a unit designation will be evaluated per the SF constant.

For example, if you have the SF set for mm and you enter

60+1"

you will get a distance mate of 85.4mm. However, it's not fixed up for compound fractions, so if you want to put in 1.25" in fractions, you would have to enter the plus sign, like 1"+1/4" rather than 1 1/4". Note that both terms have the quotes for inches. If you entered just 1+1/4", you would end up with 1mm+1/4" if you're set up for mm. If you're set up with inches for the SF, 1+1/4 will just get you 1.25" as expected.

Obviously, it's currently set up to convert inches, feet, mm, cm, and m, but if you need some other unit it's a pretty simple matter to add another Replace line.

 

[felix7502]

I would like to know where to put KenBolen's addition and then where to add handleman's. I know next to nothing about programming, so please be specific.
Thanks.
Sylvia

 

[handleman]

Here's a link to a file that includes all updates above, including Ken's.

 

[CorBlimeyLimey]

That works great handlemanand Ken. I don't have SW08 installed at work yet, so had to reset the references back to SW07.

Thanks for sharing. That must have taken a fair bit of your time to produce.

 

[smcadman]

Excellent work you guys!

I tried the distance mate macro from the book "Automating Solidworks 2006 using MACROS" but it was metric and wasn't as easy to use as this one is.

 

[felix7502]

CorBlimeyLimey -
The initial one worked with 2007, but the new one doesn't. How did you reset the references? Thanks.
Also thanks to the guys that created this.
Sylvia

 

[handleman]

You need to edit the macro (Tools->Macro->Edit), and in the VBA editor go to Tools->References. A dialog will pop up that will have a list with checkboxes. Several of the checkboxes will probably say, "MISSING:" and then something about SolidWorks 2008. Look in the list for the 2007 versions of each of the missing references (the names should be pretty much the same except with 2007 instead of 2008) and check their boxes, then un-check the the boxes for the missing references.

 

[CorBlimeyLimey]

felix7502 ...
Open the macro with the Edit macro tool, then in Tools > References deselect the 2008 refs and select the corresponding 2007 refs. Then close and save the macro.

 

[felix7502]

Thanks. It works perfectly!