Sub 插入孔() Call sw初始化("") 总数 = SelMgr.GetSelectedObjectCount2(-1) Set 边线1阵列方向 = Nothing For i = 1 To 总数 Set 对象 = SelMgr.GetSelectedObject6(i, -1) nSelType = SelMgr.GetSelectedObjectType3(i, -1) Select Case nSelType Case swSelFACES Set 放置面 = 对象 Case swSelEDGES, swSelEXTSKETCHSEGS If 边线1阵列方向 Is Nothing Then Set 边线1阵列方向 = 对象 Else Set 边线2 = 对象 End If End Select Next If 边线1阵列方向 Is Nothing Then Dim s As Double Dim e As Double Dim Curve As SldWorks.Curve Set 面边界 = CreateObject("Scripting.Dictionary") vEdges = 放置面.GetEdges i = 1 For Each 边 In vEdges If i <= 2 Then Set Curve = 边.GetCurve If Curve.IsLine Then bRet = Curve.GetEndParams(s, e, False, False) 线长度 = Curve.GetLength3(s, e) * 1000 If 线长度 > 11.5 Then vLineParam = Curve.LineParams If Abs(vLineParam(3)) = 1 Then Set 面边界("x") = 边 ElseIf Abs(vLineParam(4)) = 1 Then Set 面边界("y") = 边 ElseIf Abs(vLineParam(5)) = 1 Then Set 面边界("z") = 边 End If i = i + 1 End If End If End If Next If 面边界.Exists("x") And 面边界.Exists("y") Then Set 面边界("横") = 面边界("x") Set 面边界("竖") = 面边界("y") ElseIf 面边界.Exists("y") And 面边界.Exists("z") Then Set 面边界("横") = 面边界("z") Set 面边界("竖") = 面边界("y") Else Set 面边界("横") = 面边界("x") Set 面边界("竖") = 面边界("z") End If Set 边线1阵列方向 = 面边界("横") Set 边线2 = 面边界("竖") End If swModel.ClearSelection2 True numAdded = SelMgr.AddSelectionListObject(放置面, selData) 库特征全名 = Range("库特征路径") & "\" & Range("库特征名称") & ".sldlfp" boolstatus = swModel.InsertLibraryFeature(库特征全名) Set 当前库特征 = SelMgr.GetSelectedObject6(1, -1) Dim LibraryFeatureData As SldWorks.LibraryFeatureData Set LibraryFeatureData = 当前库特征.GetDefinition Status = LibraryFeatureData.AccessSelections(swModel, Nothing) Dim vLibRefs(1) As Object Set vLibRefs(0) = 边线1阵列方向 Set vLibRefs(1) = 边线2 LibraryFeatureData.SetReferences (vLibRefs) Status = 当前库特征.ModifyDefinition(LibraryFeatureData, swModel, Nothing) ' LibraryFeatureData.ReleaseSelectionAccess If 解散库特征 Then swModel.DissolveLibraryFeature End Sub Sub GetEdges_cs() Call sw初始化("") Set 对象 = SelMgr.GetSelectedObject6(1, -1) nEdgeCount = 对象.GetEdgeCount vEdges = 对象.GetEdges Dim s As Double Dim e As Double Dim Curve As SldWorks.Curve For j = 0 To (nEdgeCount - 1) Set Curve = vEdges(j).GetCurve If Curve.IsLine Then vEdges(j).Display 2, 0, 0, 1, True ' vLineParam = Curve.LineParams ' Debug.Print "Root point = (" & vLineParam(0) * 1000# & ", " & vLineParam(1) * 1000# & ", " & vLineParam(2) * 1000# & ") mm" ' Debug.Print "Direction = (" & vLineParam(3) & ", " & vLineParam(4) & ", " & vLineParam(5) & ")" bRet = Curve.GetEndParams(s, e, False, False) Debug.Print Curve.GetLength3(s, e) Else vEdges(j).Display 2, 0, 0, 0, True End If Next j End Sub Sub 插入孔cs() Call sw初始化("") Set 拟重装组件 = CreateObject("Scripting.Dictionary") Set 坐标参考对象 = CreateObject("Scripting.Dictionary") Set 选择的组件对象 = CreateObject("Scripting.Dictionary") Set 放置面 = SelMgr.GetSelectedObject6(1, -1) If 放置面 Is Nothing Then ' AppActivate ThisWorkbook.Name MsgBox "没有选择 放置面 !", vbInformation Exit Sub End If boolstatus = swModel.InsertLibraryFeature("D:\企业模板\库特征\光孔.sldlfp") Set 当前库特征 = SelMgr.GetSelectedObject6(1, -1) Debug.Print 当前库特征.Name ' boolstatus = swModel.Extension.SelectByID2("光孔<1>", "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0) swModel.DissolveLibraryFeature End Sub Sub 插入孔cs2() Call sw初始化("") 总数 = SelMgr.GetSelectedObjectCount2(-1) Set 边线1阵列方向 = Nothing For i = 1 To 总数 Set 对象 = SelMgr.GetSelectedObject6(i, -1) nSelType = SelMgr.GetSelectedObjectType3(i, -1) Select Case nSelType Case swSelFACES Set 放置面 = 对象 Case swSelEDGES If 边线1阵列方向 Is Nothing Then Set 边线1阵列方向 = 对象 Else Set 边线2 = 对象 End If End Select Next Dim LibraryFeatureData As SldWorks.LibraryFeatureData Dim swFeature As SldWorks.Feature Set LibraryFeatureData = swFeatMgr.CreateDefinition(swFmLibraryFeature) 库特征全名 = Range("库特征路径") & "\" & Range("库特征名称") & ".sldlfp" Status = LibraryFeatureData.Initialize(库特征全名) nRefCount = LibraryFeatureData.GetReferencesCount vRefs = LibraryFeatureData.GetReferences2(swLibFeatureData_FeatureRespect, vRefTypes) ' If Not IsEmpty(vRefTypes) Then ' Debug.Print "Types of references required (edge = 1): " ' For Each refType In vRefTypes ' Debug.Print " " & CStr(refType) ' Next ' End If ' LibraryFeatureData.ConfigurationName = "默认" swModel.ClearSelection2 True numAdded = SelMgr.AddSelectionListObject(放置面, selData) Set swFeature = swFeatMgr.CreateFeature(LibraryFeatureData) Set swFeature = SelMgr.GetSelectedObject6(1, -1) '上一步可能返回nothing Set LibraryFeatureData = Nothing Set LibraryFeatureData = swFeature.GetDefinition Status = LibraryFeatureData.AccessSelections(swModel, Nothing) Dim vLibRefs(1) As Object Set vLibRefs(0) = 边线1阵列方向 Set vLibRefs(1) = 边线2 LibraryFeatureData.SetReferences (vLibRefs) Status = swFeature.ModifyDefinition(LibraryFeatureData, swModel, Nothing) ' LibraryFeatureData.ReleaseSelectionAccess swModel.DissolveLibraryFeature End Sub Sub 获取库特征数据() Call sw初始化("") Set 库特征 = SelMgr.GetSelectedObject6(1, -1) Set LibraryFeatureData = 库特征.GetDefinition boolstatus = LibraryFeatureData.AccessSelections(swModel, Nothing) ' Get the references vRefs = LibraryFeatureData.GetReferences3(swLibFeatureData_e.swLibFeatureData_PartRespect, vRefType, vRefName) If Not IsEmpty(vRefType) Then Debug.Print "Reference types and names: " For i = LBound(vRefType) To UBound(vRefType) Debug.Print " " & vRefType(i) & ", " & vRefName(i) vRefs(i).Select False Next i End If 'Release the selections that define the library feature LibraryFeatureData.ReleaseSelectionAccess End Sub
相关文章：