找回密码 注册 QQ登录
一站式解决方案

iCAx开思网

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

[分享] 更改装配体特征树标准件图标——更新适用2014——2017

[复制链接]
发表于 2017-7-5 23:40:51 | 显示全部楼层 |阅读模式

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

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

x
本帖最后由 lkai 于 2017-7-18 22:07 编辑

更改装配体特征树标准件图标

功能:从装配体中选择一个或多个零件,将其图标更改成“标准件”图标,同样,也可以将图标还原。
操作间下图:


适用sw2013及以下——宏文件下载地址:
源代码如下:
  1. ' ------------------------------------------------------------------------------
  2. ' ChangeToolboxPartProperty
  3. ' ChangeToolboxPartProperty.swp -  by Lunkay, Copyright 2017/7/4
  4. ' Contact:  313618812@qq.com (Lunkay)

  5. ' 功能:
  6. '       选中零件,更改标准件图标属性。
  7. '
  8. ' 使用方法:
  9. ' 无
  10. 'BGU: 有时kill文件报错,无权限
  11. ' -------------------------------------------------------------------------------

  12. #If VBA7 Then
  13.     Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  14. #Else
  15.     Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  16. #End If


  17. Dim swDM As SwDMApplication
  18. Dim swDoc As SwDMDocument12
  19. Dim mOpenErrors As SwDmDocumentOpenError
  20. Dim swCfgMgr As SwDMConfigurationMgr
  21. Dim objClassfac As SwDMClassFactory
  22. Const SWDMLicenseKey = "LicenseKey"


  23. Dim swApp As SldWorks.SldWorks
  24. Dim swModel As SldWorks.ModelDoc2
  25. Dim swComp As SldWorks.Component2
  26. Dim swCompModel As SldWorks.ModelDoc2

  27. Dim ArrSelectedObjects() As Variant

  28. Dim sCompName As String

  29. Dim sMgr As SldWorks.SelectionMgr
  30. Dim sTyp As SwConst.swSelectType_e
  31. Dim iReply As String
  32. Dim swFrame As SldWorks.Frame    ' declare status bar object

  33. Dim nRetval As Long
  34. Dim bRet As Boolean
  35. Dim nErrors As Long
  36. Dim nWarnings As Long
  37. Dim mlngSWFileType As Long
  38. Dim ret As Integer

  39. Dim FilePath As String

  40. Dim ml As String

  41. Dim keys(0 To 255) As Byte

  42. Dim n As Long
  43. Dim CurSelCount As Long

  44. Dim swCompPartName As String
  45. Dim longstatus As Long, longwarnings As Long

  46. Public BZJ As Long


  47. Const MINSELECTIONS = 1

  48. Sub main()
  49.     FrmChangeToolboxPartProperty.Show
  50.     Set swApp = Application.SldWorks

  51.     Set swModel = swApp.ActiveDoc

  52.     If swModel Is Nothing Then
  53.         MsgBox "请先打开一个装配体文件!  ", vbCritical, "更改标准件标记 By Lunkay"
  54.         End

  55.     End If

  56.     If swModel.GetType = 2 Then    '如果模型是“装配体”

  57.         Set sMgr = swModel.SelectionManager
  58.         
  59.         If sMgr.GetSelectedObjectCount < MINSELECTIONS Then
  60.         
  61.             MsgBox "下面请在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  62.             
  63.         Else
  64.         
  65.         End If
  66.         
  67.         While sMgr.GetSelectedObjectCount < MINSELECTIONS
  68.         
  69.             DoEvents
  70.             GetKeyboardState keys(0)

  71.             If keys(27) > 127 Then End

  72.         Wend
  73.       
  74.         CurSelCount = sMgr.GetSelectedObjectCount
  75.         
  76.         ReDim ArrSelectedObjects(1 To CurSelCount)
  77.         AtIndex = 1
  78.         
  79.         For n = 1 To CurSelCount

  80.                 Set ArrSelectedObjects(n) = sMgr.GetSelectedObjectsComponent2(n)
  81.         Next n

  82.         For n = 1 To CurSelCount
  83.                 sMgr.DeSelect AtIndex
  84.         Next n

  85.         For n = 1 To CurSelCount

  86.              Set swComp = ArrSelectedObjects(n)
  87.             If swComp Is Nothing Then

  88.                 MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  89.             
  90.                 End

  91.             Else

  92.                 If swComp.GetSuppression = 1 Or swComp.GetSuppression = 4 Then    '零件压缩状态为轻化

  93.                     nRetval = swComp.SetSuppression2(2)    '将轻化还原

  94.                 End If
  95.                 sCompName = swComp.GetPathName
  96.             
  97.                 Set swCompModel = swApp.ActivateDoc2(sCompName, True, nRetval)

  98.                 Set swCompModel = swApp.ActiveDoc

  99.                 swCompPartName = swCompModel.GetTitle

  100.                 If swCompModel.GetType <> 1 Then

  101.                     MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  102.                     End

  103.                 End If

  104.                 longstatus = swCompModel.SaveAs3("C:\更改标准件标记.SLDPRT", 0, 1)
  105.                 Set swCompModel = Nothing
  106.                 swApp.CloseDoc "更改标准件标记.SLDPRT"

  107.                 Set swModel = swApp.ActiveDoc

  108.                 Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
  109.                 Set swDM = objClassfac.GetApplication(SWDMLicenseKey)    '启动SWDM
  110.                 Set swDoc = swDM.GetDocument(sCompName, 1, False, mOpenErrors)

  111.                 If BZJ = 1 Then    '变成标准件图标

  112.                     If swDoc.ToolboxPart <> swDmNotAToolboxPart Then

  113.                         MsgBox "所选零件是标准件!请选择一个非标准件!", vbCritical, "更改标准件标记 By Lunkay"
  114.                     
  115.                         swDoc.CloseDoc
  116.                         sMgr.DeSelect 1
  117.                         bRet = swComp.Select(True)
  118.                         bRet = swModel.ReplaceComponents(sCompName, "", True, True)
  119.                     
  120.                         Kill "C:\更改标准件标记.SLDPRT"
  121.                     
  122.                         End
  123.                     
  124.                     Else

  125.                         swDoc.ToolboxPart = swDmToolboxStandardPart

  126.                         swDoc.Save
  127.                         swDoc.CloseDoc
  128.                         'sMgr.DeSelect 1
  129.                         bRet = swComp.Select(True)

  130.                         bRet = swModel.ReplaceComponents(sCompName, "", True, True)

  131.                         Kill "C:\更改标准件标记.SLDPRT"

  132.                     End If

  133.                 ElseIf BZJ = 0 Then    '变成零件图标

  134.                     If swDoc.ToolboxPart = swDmNotAToolboxPart Then

  135.                         MsgBox "所选零件不是标准件!", vbCritical, "更改标准件标记 By Lunkay"
  136.                         swDoc.CloseDoc
  137.                         sMgr.DeSelect 1
  138.                         bRet = swComp.Select(True)
  139.                         bRet = swModel.ReplaceComponents(sCompName, "", True, True)
  140.                         Kill "C:\更改标准件标记.SLDPRT"     
  141.                         End
  142.                     Else
  143.                         swDoc.ToolboxPart = swDmNotAToolboxPart
  144.                         swDoc.Save
  145.                         swDoc.CloseDoc
  146.                         sMgr.DeSelect 1
  147.                         bRet = swComp.Select(True)
  148.                         bRet = swModel.ReplaceComponents(sCompName, "", True, True)
  149.                         Kill "C:\更改标准件标记.SLDPRT"
  150.                     End If
  151.                 End If
  152.             End If
  153.         Next n
  154.         swModel.ClearSelection2 True
  155.     Else
  156.         MsgBox "请打开标装配体文件后再运行本程序!", vbCritical, "更改标准件标记 By Lunkay"
  157.     End If
  158. End Sub

复制代码


更新:适用于2014——2017
SW宏文件在此下载:
源代码如下:
  1. ' ------------------------------------------------------------------------------
  2. ' ChangeToolboxPartProperty
  3. ' ChangeToolboxPartProperty.swp -  by Lunkay, Copyright 2017/7/4
  4. ' Contact:  313618812@qq.com (Lunkay)

  5. ' 功能:
  6. '       选中零件,更改标准件图标属性。
  7. '
  8. ' 使用方法:
  9. ' 适用于SOLIDWORKS2014_2017
  10. 'BGU: 有时kill文件报错,无权限
  11. ' -------------------------------------------------------------------------------

  12. #If VBA7 Then
  13.     Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  14. #Else
  15.     Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  16. #End If


  17. Dim swApp As Object
  18. Dim swModel As Object
  19. Dim swComp As Object
  20. Dim swCompModel As Object

  21. Dim ArrSelectedObjects() As Variant

  22. Dim sCompName As String

  23. Dim sMgr As Object

  24. Dim iReply As String
  25. Dim swFrame As Object    ' declare status bar object

  26. Dim nRetval As Long
  27. Dim bRet As Boolean
  28. Dim nErrors As Long
  29. Dim nWarnings As Long
  30. Dim mlngSWFileType As Long
  31. Dim ret As Integer

  32. Dim FilePath As String

  33. Dim ml As String

  34. Dim keys(0 To 255) As Byte

  35. Dim n As Long
  36. Dim CurSelCount As Long
  37. Dim AtIndex  As Long

  38. Dim swCompPartName As String
  39. Dim longstatus As Long, longwarnings As Long

  40. Public BZJ As Long

  41. Dim modelDocExt As Object

  42. Const MINSELECTIONS = 1

  43. Sub main()
  44.     FrmChangeToolboxPartProperty.Show
  45.     Set swApp = Application.SldWorks

  46.     Set swModel = swApp.ActiveDoc

  47.     If swModel Is Nothing Then
  48.         MsgBox "请先打开一个装配体文件!  ", vbCritical, "更改标准件标记 By Lunkay"
  49.         End

  50.     End If

  51.     If swModel.GetType = 2 Then    '如果模型是“装配体”

  52.         Set sMgr = swModel.SelectionManager
  53.         
  54.         If sMgr.GetSelectedObjectCount < MINSELECTIONS Then
  55.         
  56.             MsgBox "下面请在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  57.             
  58.         Else

  59.         End If

  60.         While sMgr.GetSelectedObjectCount < MINSELECTIONS
  61.         
  62.             DoEvents
  63.             GetKeyboardState keys(0)

  64.             If keys(27) > 127 Then End

  65.         Wend

  66.         CurSelCount = sMgr.GetSelectedObjectCount
  67.         
  68.         ReDim ArrSelectedObjects(1 To CurSelCount)
  69.         AtIndex = 1
  70.         
  71.         For n = 1 To CurSelCount

  72.                 Set ArrSelectedObjects(n) = sMgr.GetSelectedObjectsComponent2(n)

  73.         Next n

  74.         For n = 1 To CurSelCount

  75.                 sMgr.DeSelect AtIndex

  76.         Next n

  77.         For n = 1 To CurSelCount

  78.              Set swComp = ArrSelectedObjects(n)
  79.             If swComp Is Nothing Then

  80.                 MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  81.             
  82.                 End

  83.             Else

  84.                 If swComp.GetSuppression = 1 Or swComp.GetSuppression = 4 Then    '零件压缩状态为轻化

  85.                     nRetval = swComp.SetSuppression2(2)    '将轻化还原

  86.                 End If
  87.                 sCompName = swComp.GetPathName
  88.             
  89.                 Set swCompModel = swApp.ActivateDoc2(sCompName, True, nRetval)

  90.                 Set swCompModel = swApp.ActiveDoc

  91.                 swCompPartName = swCompModel.GetTitle

  92.                 If swCompModel.GetType <> 1 Then

  93.                     MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
  94.                     End

  95.                 End If

  96.                 Set modelDocExt = swCompModel.Extension

  97.                 If BZJ = 1 Then    '变成标准件图标

  98.                     If modelDocExt.ToolboxPartType <> 0 Then

  99.                         MsgBox "所选零件是标准件!请选择一个非标准件!", vbCritical, "更改标准件标记 By Lunkay"

  100.                         End
  101.                     
  102.                     Else

  103.                         modelDocExt.ToolboxPartType = 1

  104.                         swCompModel.Save

  105.                     End If

  106.                 ElseIf BZJ = 0 Then    '变成零件图标

  107.                     If modelDocExt.ToolboxPartType = 0 Then

  108.                         MsgBox "所选零件不是标准件!", vbCritical, "更改标准件标记 By Lunkay"

  109.                         End

  110.                     Else

  111.                         modelDocExt.ToolboxPartType = 0

  112.                         swCompModel.Save

  113.                     End If

  114.                 End If

  115.             End If

  116.         Next n

  117.         swModel.ClearSelection2 True
  118.     Else
  119.    
  120.         MsgBox "请打开标装配体文件后再运行本程序!", vbCritical, "更改标准件标记 By Lunkay"

  121.     End If

  122. End Sub

复制代码





评分

参与人数 1贡献 +5 收起 理由
gt.adan + 5 謝謝分享~

查看全部评分

发表于 2017-7-5 23:47:52 | 显示全部楼层

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

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

x
 楼主| 发表于 2017-7-5 23:56:19 | 显示全部楼层

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

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

x
发表于 2017-7-6 03:26:46 | 显示全部楼层

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

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

x
发表于 2017-7-6 05:59:57 | 显示全部楼层

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

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

x
发表于 2017-7-6 07:42:15 | 显示全部楼层

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

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

x
发表于 2017-7-6 08:16:48 | 显示全部楼层

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

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

x
 楼主| 发表于 2017-7-6 08:20:16 | 显示全部楼层

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

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

x
 楼主| 发表于 2017-7-6 08:22:38 | 显示全部楼层

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

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

x
发表于 2017-7-6 10:07:03 | 显示全部楼层

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

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

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

本版积分规则

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

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

GMT+8, 2024-3-29 23:52 , Processed in 0.028853 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.3

© 2002-2024 www.iCAx.org

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