找回密码 注册 QQ登录
开思网工业级高精度在线3D打印服务

iCAx开思网

CAD/CAM/CAE/设计/模具 高清视频【积分说明】如何快速获得积分?在线3D打印服务,一键上传,自动报价 
查看: 4615|回复: 17

[原创] 强迫症福音宏-集合同名零件

[复制链接]
发表于 2020-8-10 15:05:22 | 显示全部楼层 |阅读模式
本帖最后由 甄云竹 于 2020-8-12 18:16 编辑

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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-11 13:52:14 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-11 15:07:49 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-11 17:34:49 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-12 08:54:42 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-12 14:02:00 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
 楼主| 发表于 2020-8-12 16:28:49 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
 楼主| 发表于 2020-8-12 16:31:12 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-13 08:38:38 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2020-8-31 15:22:50 | 显示全部楼层

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

3D打印手板模型快速制作服务,在线报价下单!

QQ 咨询|手机版|联系我们|iCAx开思网  

GMT+8, 2024-3-28 17:11 , Processed in 0.025582 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.3

© 2002-2024 www.iCAx.org

快速回复 返回顶部 返回列表