强迫症福音宏-集合同名零件

甄云竹

改编自SOLIDWORKS API帮助中的例子"Move Assembly Components to New Folder Example (VBA)"

在原例基础上添加力遍历代码，在设计树中集合与选中零部件同名且同层的所有零件，移动到选中零件之后。

1. Dim swApp As SldWorks.SldWorks
   
2. Dim actDoc As SldWorks.AssemblyDoc
   
3. Dim selectMgr As SldWorks.SelectionMgr
   
4. Dim curFeature As SldWorks.Feature
   
5. Dim targetComp As SldWorks.Component2
   
6. Dim curComponent As SldWorks.Component2
   
7. Dim parentComp As SldWorks.Component2
   
8. Dim componentsToMove() As SldWorks.Component2
   
9. Dim targetNameSplit() As String
   
10. Dim count As Long
    
11. Dim retVal As Boolean
    
12. Dim featureName As String
    
13. Dim featureType As String
    
14. Dim targetName As String
    
15. Dim compName As String
    
16. Dim curCompName As String
    
17. Sub Main()
    
18.     Set swApp = Application.SldWorks
    
19.     Set actDoc = swApp.ActiveDoc
    
20.     Set selectMgr = actDoc.SelectionManager
    
21.     Set targetComp = selectMgr.GetSelectedObjectsComponent4(1, -1) '获取选中零件
    
22.     Set parentComp = targetComp.GetParent '获取父级零件
    
23.     targetName = targetComp.Name2 '获取选中零件的层级名称
    
24.     targetNameSplit = Split(targetName, "/") '分解层级名称
    
25.     compName = targetNameSplit(UBound(targetNameSplit))
    
26.     compName = Left(compName, InStrRev(compName, "-") - 1) '去除末端序号
    
27.     count = 0
    
28.     ReDim componentsToMove(count)
    
29.     If parentComp Is Nothing Then '没有父级零件，代表是顶层零件
    
30.         Set curFeature = actDoc.FirstFeature
    
31.     Else
    
32.         Set curFeature = parentComp.FirstFeature
    
33.     End If
    
34.     Do Until curFeature Is Nothing '循环到特征为空
    
35.         featureName = curFeature.Name '获取特征名称
    
36.         featureType = curFeature.GetTypeName2
    
37.         If featureType = "Reference" Then '只选中零部件
    
38.             curCompName = Left(featureName, InStrRev(featureName, "-") - 1) '去除末端序号
    
39.             If curCompName = compName Then '筛选出同名零件
    
40.                 retVal = curFeature.Select2(True, count + 1) '选中零件
    
41.                 Set curComponent = selectMgr.GetSelectedObject6(count + 1, -1) '获取零件对象
    
42.                 ReDim Preserve componentsToMove(count)
    
43.                 Set componentsToMove(count) = curComponent '将零件存入数组
    
44.                 count = count + 1
    
45.             End If
    
46.         End If
    
47.         Set curFeature = curFeature.GetNextFeature() '选中下一个特征
    
48.     Loop
    
49.     retVal = actDoc.ReorderComponents(componentsToMove, targetComp, swReorderComponentsWhere_e.swReorderComponents_After) '将零件移动到指定零件后
    
50. End Sub
    

复制代码

人穷貌丑

Trouble12138

xiaocake

羊三丫

xiaocake

甄云竹

甄云竹

xiaocake

lg328084985