跳到主要内容

SOLIDWORKS宏以查找零件之间的几何差异

此宏允许通过其几何形状比较两个零件。

使用SOLIDWORKS API的IBody2::GetCoincidenceTransform2来比较零件,如果相等,则找到它们之间的变换。

注意事项

  • 宏支持多体零件
  • 即使可比较的零件位于不同的位置(即移动或旋转),宏也会比较它们的几何体。
  • 可比较的零件可能具有不同数量的几何体
  • 宏将尝试找到两个零件之间最合适的变换

示例

要比较的原始零件:

原始零件{ width=250 }

要比较的零件

要比较的零件{ width=250 }

第二个零件具有修改后的几何形状,并在空间中重新定位。第二个零件中的一些几何体已被删除。

该宏计算出以下结果:

结果差异文件{ width=250 }

指令

  • 打开原始零件文件
  • 运行宏。
  • 指定要与之比较的零件文件的完整路径
  • 结果将在原始零件中显示第二个零件
  • 继续运行宏(F5)以清除预览
Dim swApp As SldWorks.SldWorks

Sub main()

Set swApp = Application.SldWorks

Dim swPart As SldWorks.PartDoc

Set swPart = swApp.ActiveDoc

If Not swPart Is Nothing Then

Dim otherFilePath As String
otherFilePath = InputBox("请指定要比较的零件路径")

If otherFilePath <> "" Then

Dim swOtherPart As SldWorks.PartDoc
Set swOtherPart = swApp.OpenDoc6(otherFilePath, swDocumentTypes_e.swDocPART, swOpenDocOptions_e.swOpenDocOptions_Silent, "", 0, 0)

If Not swOtherPart Is Nothing Then
Dim swXform As SldWorks.MathTransform
Set swXform = GetClosestTransform(swPart, swOtherPart)
PreviewPart swOtherPart, swXform, swPart
Else
MsgBox "无法打开要比较的零件"
End If

End If

Else
MsgBox "请打开零件"
End If

End Sub

Sub PreviewPart(part As SldWorks.PartDoc, transform As SldWorks.MathTransform, context As PartDoc)

Dim vBodies As Variant

vBodies = part.GetBodies2(swBodyType_e.swSolidBody, True)

Dim i As Integer

For i = 0 To UBound(vBodies)

Dim swBody As SldWorks.Body2
Set swBody = vBodies(i)
Set swBody = swBody.Copy

If Not transform Is Nothing Then
Debug.Print swBody.ApplyTransform(transform)
End If

Set vBodies(i) = swBody
swBody.Display3 context, RGB(255, 255, 0), swTempBodySelectOptions_e.swTempBodySelectOptionNone

Next

Stop '继续运行宏以隐藏预览

End Sub

Function GetClosestTransform(thisPart As SldWorks.PartDoc, otherPart As SldWorks.PartDoc) As SldWorks.MathTransform

Dim vThisBodies As Variant
Dim vOtherBodies As Variant

vThisBodies = thisPart.GetBodies2(swBodyType_e.swSolidBody, True)
vOtherBodies = otherPart.GetBodies2(swBodyType_e.swSolidBody, True)

Dim transformsHits As Object
Set transformsHits = CreateObject("Scripting.Dictionary") '由于某些原因,有时在创建时会添加第一个空元素

If Not IsEmpty(vThisBodies) And Not IsEmpty(vOtherBodies) Then

Dim i As Integer
Dim j As Integer

For i = 0 To UBound(vOtherBodies)

Dim swOtherBody As SldWorks.Body2

Set swOtherBody = vOtherBodies(i)

For j = 0 To UBound(vThisBodies)

Dim swThisBody As SldWorks.Body2
Set swThisBody = vThisBodies(j)
Dim swTransform As SldWorks.MathTransform

If swThisBody.GetCoincidenceTransform2(swOtherBody, swTransform) Then

If Not swTransform Is Nothing Then

Dim contains As Boolean
contains = False
For Each key In transformsHits.Keys
If Not key Is Nothing Then
Dim tx As SldWorks.MathTransform
Set tx = key
If CompareTransforms(swTransform, tx) Then
transformsHits(tx) = transformsHits(tx) + 1
contains = True
Exit For
End If
End If
Next

If Not contains Then
transformsHits.Add swTransform, 1
End If

End If

End If

Next

Next

End If

Dim curMaxHit As Integer
curMaxHit = 0

For Each key In transformsHits.Keys
If Not key Is Nothing Then
Dim curTx As SldWorks.MathTransform
Set curTx = key
If transformsHits(curTx) > curMaxHit Then
curMaxHit = transformsHits(curTx)
Set GetClosestTransform = curTx
End If
End If
Next

End Function

Function CompareTransforms(firstTransform As SldWorks.MathTransform, secondTransform As SldWorks.MathTransform) As Boolean

Dim vFirstArrayData As Variant
vFirstArrayData = firstTransform.ArrayData

Dim vSecondArrayData As Variant
vSecondArrayData = secondTransform.ArrayData

Dim i As Integer

For i = 0 To UBound(vFirstArrayData)
If Not CompareValues(CDbl(vFirstArrayData(i)), CDbl(vSecondArrayData(i))) Then
CompareTransforms = False
Exit Function
End If
Next

CompareTransforms = True

End Function

Function CompareValues(firstValue As Double, secondValue As Double, Optional tol As Double = 0.00000001) As Boolean

CompareValues = Abs(secondValue - firstValue) <= tol

End Function