iCAx开思网

标题: 强迫症福音宏-集合同名零件 [打印本页]
作者: 甄云竹    时间: 2020-8-10 15:05
标题: 强迫症福音宏-集合同名零件
本帖最后由 甄云竹 于 2020-8-12 18:16 编辑

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

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

  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
复制代码


作者: 人穷貌丑    时间: 2020-8-11 13:52
求分享代码
作者: Trouble12138    时间: 2020-8-11 15:07
求分享
作者: xiaocake    时间: 2020-8-11 17:34
装配体模型树排序宏的前身,鉴定完毕！
作者: 羊三丫    时间: 2020-8-12 08:54
xiaocake 发表于 2020-8-11 17:34
装配体模型树排序宏的前身,鉴定完毕！

我想对于镜像,阵列的零件就无效了
作者: xiaocake    时间: 2020-8-12 14:02
羊三丫 发表于 2020-8-12 08:54
我想对于镜像,阵列的零件就无效了

阵列里面的零部件你还要排序？？？这强迫症得是啥境界了


作者: 甄云竹    时间: 2020-8-12 16:28
本帖最后由 甄云竹 于 2020-8-12 16:30 编辑

我想分享代码，但是却发不出来，好奇怪
作者: 甄云竹    时间: 2020-8-12 16:31
本帖最后由 甄云竹 于 2020-8-12 18:19 编辑

翻个墙出来就能插入代码发表了，这论坛以后不想来了
作者: xiaocake    时间: 2020-8-13 08:38
甄云竹 发表于 2020-8-12 16:31
翻个墙出来就能插入代码发表了，这论坛以后不想来了

前阵子这个网站的服务器估计崩溃了，无法访问，这两天可以登录了，但是我最后发的帖子丢了，太不靠谱了！！！
附件大小也限制得厉害，想发个动图都不行。。。

作者: lg328084985    时间: 2020-8-31 15:22
甄云竹 发表于 2020-8-12 16:28
我想分享代码，但是却发不出来，好奇怪

大神可以帮我写一个更改切割清单名称的宏吗
作者: Jiacai007    时间: 2020-9-24 23:17
感谢UP主
作者: erikgqp8645    时间: 2020-10-9 21:35
多谢大佬
作者: zhang961670949    时间: 2020-10-28 09:02
厉害厉害。学习了
作者: fend    时间: 2021-8-22 21:28
这个好，不用来回拉设计树了
作者: fan03488    时间: 2021-11-8 18:57
强迫症的福音,哈哈
作者: zctao1966    时间: 2022-4-12 22:41
感谢分享，学习了
作者: sen8337    时间: 2022-10-21 08:37
谢谢楼主的资料！
作者: 羊三丫    时间: 2023-2-1 16:29
请问一下，在你的截图里看到了”恢复名称关联“的宏，这个宏的作用是什么？是可以修改丢失的外部参考吗？




欢迎光临 iCAx开思网 (https://www.icax.org/) Powered by Discuz! X3.3