|
|
|
Dim swApp As SldWorks.SldWorks Dim actDoc As SldWorks.AssemblyDoc Dim selectMgr As SldWorks.SelectionMgr Dim curFeature As SldWorks.Feature Dim targetComp As SldWorks.Component2 Dim curComponent As SldWorks.Component2 Dim parentComp As SldWorks.Component2 Dim componentsToMove() As SldWorks.Component2 Dim targetNameSplit() As String Dim count As Long Dim retVal As Boolean Dim featureName As String Dim featureType As String Dim targetName As String Dim compName As String Dim curCompName As String Sub Main() Set swApp = Application.SldWorks Set actDoc = swApp.ActiveDoc Set selectMgr = actDoc.SelectionManager Set targetComp = selectMgr.GetSelectedObjectsComponent4(1, -1) '获取选中零件 Set parentComp = targetComp.GetParent '获取父级零件 targetName = targetComp.Name2 '获取选中零件的层级名称 targetNameSplit = Split(targetName, "/") '分解层级名称 compName = targetNameSplit(UBound(targetNameSplit)) compName = Left(compName, InStrRev(compName, "-") - 1) '去除末端序号 count = 0 ReDim componentsToMove(count) If parentComp Is Nothing Then '没有父级零件，代表是顶层零件 Set curFeature = actDoc.FirstFeature Else Set curFeature = parentComp.FirstFeature End If Do Until curFeature Is Nothing '循环到特征为空 featureName = curFeature.Name '获取特征名称 featureType = curFeature.GetTypeName2 If featureType = "Reference" Then '只选中零部件 curCompName = Left(featureName, InStrRev(featureName, "-") - 1) '去除末端序号 If curCompName = compName Then '筛选出同名零件 retVal = curFeature.Select2(True, count + 1) '选中零件 Set curComponent = selectMgr.GetSelectedObject6(count + 1, -1) '获取零件对象 ReDim Preserve componentsToMove(count) Set componentsToMove(count) = curComponent '将零件存入数组 count = count + 1 End If End If Set curFeature = curFeature.GetNextFeature() '选中下一个特征 Loop retVal = actDoc.ReorderComponents(componentsToMove, targetComp, swReorderComponentsWhere_e.swReorderComponents_After) '将零件移动到指定零件后 End Sub |
|
[复制链接]
发表于 2021-12-10 15:07:00
鲁公网安备 37028502190335号