大板配孔ds片求优化

dragon045 · 发表于 2025-3-1 09:13:01

经典图书

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc

Sub Main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

If Not TypeOf swModel Is AssemblyDoc Then
      MsgBox "请打开装配体文件"
      Exit Sub
End If

Set swAssy = swModel

' 获取用户选择的大板面
Dim swSelMgr As SelectionMgr
Set swSelMgr = swModel.SelectionManager

If swSelMgr.GetSelectedObjectCount2(-1) <> 1 Then
      MsgBox "请选择大板的一个面"
      Exit Sub
End If

Dim swFace As face
Set swFace = swSelMgr.GetSelectedObject6(1, -1)

If swFace Is Nothing Then
      MsgBox "选择无效，请重新选择面"
      Exit Sub
End If

' 获取大板组件
Dim swBaseComp As Component2
Set swBaseComp = swFace.GetComponent

' 查找所有重合配合面
Dim holeData As Collection
Set holeData = New Collection

FindMatchingHoles swFace, holeData

If holeData.Count > 0 Then
      CreateThreadHoles swBaseComp, swFace, holeData
      MsgBox "成功创建 " & holeData.Count & " 个螺纹孔"
Else
      MsgBox "未找到匹配的孔特征"
End If
End Sub

Sub FindMatchingHoles(baseFace As face, ByRef holes As Collection)
Dim swMateGroup As MateGroup
Set swMateGroup = swAssy.GetMateGroup(0)

Dim vMates As Variant
vMates = swMateGroup.GetMates

Dim i As Integer
For i = 0 To UBound(vMates)
      Dim swMate As Mate2
      Set swMate = vMates(i)

      If swMate.GetType = swMateType_e.swMateCOINCIDENT Then
         ProcessCoincidentMate swMate, baseFace, holes
      End If
Next
End Sub

Sub ProcessCoincidentMate(mate As Mate2, baseFace As face, ByRef holes As Collection)
Dim mateEnts As Variant
mateEnts = mate.GetEntities

Dim otherFace As face
Dim otherComp As Component2

' 确定配合的另一个面
If mateEnts(0).face Is baseFace Then
      Set otherFace = mateEnts(1).face
      Set otherComp = mateEnts(1).Component
ElseIf mateEnts(1).face Is baseFace Then
      Set otherFace = mateEnts(0).face
      Set otherComp = mateEnts(0).Component
Else
      Exit Sub
End If

' 获取孔特征数据
Dim swPart As ModelDoc2
Set swPart = otherComp.GetModelDoc2

If swPart Is Nothing Then Exit Sub

Dim vHoleFeats As Variant
vHoleFeats = GetHolesOnFace(swPart, otherFace)

If Not IsEmpty(vHoleFeats) Then
      Dim holeFeat As Variant
      For Each holeFeat In vHoleFeats
         holes.Add holeFeat
      Next
End If
End Sub

Function GetHolesOnFace(part As ModelDoc2, face As face) As Variant
Dim holes As Collection
Set holes = New Collection

Dim swFeat As Feature
Set swFeat = part.FirstFeature

While Not swFeat Is Nothing
      If swFeat.GetTypeName2 = "Hole" Then
         Dim swHole As HoleFeatureData
         Set swHole = swFeat.GetDefinition

         Dim swFaceHole As face
         Set swFaceHole = swHole.GetFaces(0) ' 获取孔所在面

         If swFaceHole Is face Then
            Dim holeInfo(2) As Double
            holeInfo(0) = swHole.HoleDiameter
            holeInfo(1) = swHole.HoleDepth
            holes.Add holeInfo
         End If
      End If
      Set swFeat = swFeat.GetNextFeature
Wend

GetHolesOnFace = holes.ToArray
End Function

Sub CreateThreadHoles(baseComp As Component2, baseFace As face, holes As Collection)
Dim swPart As PartDoc
Set swPart = baseComp.GetModelDoc2

swPart.Extension.SelectByID2 baseFace.Name, "FACE", 0, 0, 0, False, 0, Nothing, 0

Dim swFeatMgr As FeatureManager
Set swFeatMgr = swPart.FeatureManager

Dim holeDef As HoleMgrDef
Set holeDef = swFeatMgr.CreateHoleMgrDefinition(swHoleType_e.swHoleType_StraightTap)

' 设置螺纹孔参数
holeDef.StandardIndex = swHoleStandard_AnsiMetric
holeDef.FastenerTypeIndex = swHoleFastenerType_MetricTap

For Each holeData In holes
      Dim diameter As Double
      diameter = holeData(0)

      holeDef.HoleDiameter = diameter
      holeDef.TapDrillDiameter = diameter - 0.2 ' 根据标准计算
      holeDef.ThreadDepth = holeData(1)

      ' 创建孔特征
      swFeatMgr.InsertHoleMgr holeDef
Next
End Sub