|
马上注册,结交更多同行朋友,交流,分享,学习。
您需要 登录 才可以下载或查看,没有帐号?注册
x
本帖最后由 lkai 于 2017-7-18 22:07 编辑
更改装配体特征树标准件图标
功能:从装配体中选择一个或多个零件,将其图标更改成“标准件”图标,同样,也可以将图标还原。
操作间下图:
适用sw2013及以下——宏文件下载地址:
源代码如下:
- ' ------------------------------------------------------------------------------
- ' ChangeToolboxPartProperty
- ' ChangeToolboxPartProperty.swp - by Lunkay, Copyright 2017/7/4
- ' Contact: 313618812@qq.com (Lunkay)
- ' 功能:
- ' 选中零件,更改标准件图标属性。
- '
- ' 使用方法:
- ' 无
- 'BGU: 有时kill文件报错,无权限
- ' -------------------------------------------------------------------------------
- #If VBA7 Then
- Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
- #Else
- Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
- #End If
- Dim swDM As SwDMApplication
- Dim swDoc As SwDMDocument12
- Dim mOpenErrors As SwDmDocumentOpenError
- Dim swCfgMgr As SwDMConfigurationMgr
- Dim objClassfac As SwDMClassFactory
- Const SWDMLicenseKey = "LicenseKey"
- Dim swApp As SldWorks.SldWorks
- Dim swModel As SldWorks.ModelDoc2
- Dim swComp As SldWorks.Component2
- Dim swCompModel As SldWorks.ModelDoc2
- Dim ArrSelectedObjects() As Variant
- Dim sCompName As String
- Dim sMgr As SldWorks.SelectionMgr
- Dim sTyp As SwConst.swSelectType_e
- Dim iReply As String
- Dim swFrame As SldWorks.Frame ' declare status bar object
- Dim nRetval As Long
- Dim bRet As Boolean
- Dim nErrors As Long
- Dim nWarnings As Long
- Dim mlngSWFileType As Long
- Dim ret As Integer
- Dim FilePath As String
- Dim ml As String
- Dim keys(0 To 255) As Byte
- Dim n As Long
- Dim CurSelCount As Long
- Dim swCompPartName As String
- Dim longstatus As Long, longwarnings As Long
- Public BZJ As Long
- Const MINSELECTIONS = 1
- Sub main()
- FrmChangeToolboxPartProperty.Show
- Set swApp = Application.SldWorks
- Set swModel = swApp.ActiveDoc
- If swModel Is Nothing Then
- MsgBox "请先打开一个装配体文件! ", vbCritical, "更改标准件标记 By Lunkay"
- End
- End If
- If swModel.GetType = 2 Then '如果模型是“装配体”
- Set sMgr = swModel.SelectionManager
-
- If sMgr.GetSelectedObjectCount < MINSELECTIONS Then
-
- MsgBox "下面请在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
-
- Else
-
- End If
-
- While sMgr.GetSelectedObjectCount < MINSELECTIONS
-
- DoEvents
- GetKeyboardState keys(0)
- If keys(27) > 127 Then End
- Wend
-
- CurSelCount = sMgr.GetSelectedObjectCount
-
- ReDim ArrSelectedObjects(1 To CurSelCount)
- AtIndex = 1
-
- For n = 1 To CurSelCount
- Set ArrSelectedObjects(n) = sMgr.GetSelectedObjectsComponent2(n)
- Next n
- For n = 1 To CurSelCount
- sMgr.DeSelect AtIndex
- Next n
- For n = 1 To CurSelCount
- Set swComp = ArrSelectedObjects(n)
- If swComp Is Nothing Then
- MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
-
- End
- Else
- If swComp.GetSuppression = 1 Or swComp.GetSuppression = 4 Then '零件压缩状态为轻化
- nRetval = swComp.SetSuppression2(2) '将轻化还原
- End If
- sCompName = swComp.GetPathName
-
- Set swCompModel = swApp.ActivateDoc2(sCompName, True, nRetval)
- Set swCompModel = swApp.ActiveDoc
- swCompPartName = swCompModel.GetTitle
- If swCompModel.GetType <> 1 Then
- MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
- End
- End If
- longstatus = swCompModel.SaveAs3("C:\更改标准件标记.SLDPRT", 0, 1)
- Set swCompModel = Nothing
- swApp.CloseDoc "更改标准件标记.SLDPRT"
- Set swModel = swApp.ActiveDoc
- Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
- Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '启动SWDM
- Set swDoc = swDM.GetDocument(sCompName, 1, False, mOpenErrors)
- If BZJ = 1 Then '变成标准件图标
- If swDoc.ToolboxPart <> swDmNotAToolboxPart Then
- MsgBox "所选零件是标准件!请选择一个非标准件!", vbCritical, "更改标准件标记 By Lunkay"
-
- swDoc.CloseDoc
- sMgr.DeSelect 1
- bRet = swComp.Select(True)
- bRet = swModel.ReplaceComponents(sCompName, "", True, True)
-
- Kill "C:\更改标准件标记.SLDPRT"
-
- End
-
- Else
- swDoc.ToolboxPart = swDmToolboxStandardPart
- swDoc.Save
- swDoc.CloseDoc
- 'sMgr.DeSelect 1
- bRet = swComp.Select(True)
- bRet = swModel.ReplaceComponents(sCompName, "", True, True)
- Kill "C:\更改标准件标记.SLDPRT"
- End If
- ElseIf BZJ = 0 Then '变成零件图标
- If swDoc.ToolboxPart = swDmNotAToolboxPart Then
- MsgBox "所选零件不是标准件!", vbCritical, "更改标准件标记 By Lunkay"
- swDoc.CloseDoc
- sMgr.DeSelect 1
- bRet = swComp.Select(True)
- bRet = swModel.ReplaceComponents(sCompName, "", True, True)
- Kill "C:\更改标准件标记.SLDPRT"
- End
- Else
- swDoc.ToolboxPart = swDmNotAToolboxPart
- swDoc.Save
- swDoc.CloseDoc
- sMgr.DeSelect 1
- bRet = swComp.Select(True)
- bRet = swModel.ReplaceComponents(sCompName, "", True, True)
- Kill "C:\更改标准件标记.SLDPRT"
- End If
- End If
- End If
- Next n
- swModel.ClearSelection2 True
- Else
- MsgBox "请打开标装配体文件后再运行本程序!", vbCritical, "更改标准件标记 By Lunkay"
- End If
- End Sub
复制代码
更新:适用于2014——2017
SW宏文件在此下载:
源代码如下:- ' ------------------------------------------------------------------------------
- ' ChangeToolboxPartProperty
- ' ChangeToolboxPartProperty.swp - by Lunkay, Copyright 2017/7/4
- ' Contact: 313618812@qq.com (Lunkay)
- ' 功能:
- ' 选中零件,更改标准件图标属性。
- '
- ' 使用方法:
- ' 适用于SOLIDWORKS2014_2017
- 'BGU: 有时kill文件报错,无权限
- ' -------------------------------------------------------------------------------
- #If VBA7 Then
- Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
- #Else
- Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
- #End If
- Dim swApp As Object
- Dim swModel As Object
- Dim swComp As Object
- Dim swCompModel As Object
- Dim ArrSelectedObjects() As Variant
- Dim sCompName As String
- Dim sMgr As Object
- Dim iReply As String
- Dim swFrame As Object ' declare status bar object
- Dim nRetval As Long
- Dim bRet As Boolean
- Dim nErrors As Long
- Dim nWarnings As Long
- Dim mlngSWFileType As Long
- Dim ret As Integer
- Dim FilePath As String
- Dim ml As String
- Dim keys(0 To 255) As Byte
- Dim n As Long
- Dim CurSelCount As Long
- Dim AtIndex As Long
- Dim swCompPartName As String
- Dim longstatus As Long, longwarnings As Long
- Public BZJ As Long
- Dim modelDocExt As Object
- Const MINSELECTIONS = 1
- Sub main()
- FrmChangeToolboxPartProperty.Show
- Set swApp = Application.SldWorks
- Set swModel = swApp.ActiveDoc
- If swModel Is Nothing Then
- MsgBox "请先打开一个装配体文件! ", vbCritical, "更改标准件标记 By Lunkay"
- End
- End If
- If swModel.GetType = 2 Then '如果模型是“装配体”
- Set sMgr = swModel.SelectionManager
-
- If sMgr.GetSelectedObjectCount < MINSELECTIONS Then
-
- MsgBox "下面请在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
-
- Else
- End If
- While sMgr.GetSelectedObjectCount < MINSELECTIONS
-
- DoEvents
- GetKeyboardState keys(0)
- If keys(27) > 127 Then End
- Wend
- CurSelCount = sMgr.GetSelectedObjectCount
-
- ReDim ArrSelectedObjects(1 To CurSelCount)
- AtIndex = 1
-
- For n = 1 To CurSelCount
- Set ArrSelectedObjects(n) = sMgr.GetSelectedObjectsComponent2(n)
- Next n
- For n = 1 To CurSelCount
- sMgr.DeSelect AtIndex
- Next n
- For n = 1 To CurSelCount
- Set swComp = ArrSelectedObjects(n)
- If swComp Is Nothing Then
- MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
-
- End
- Else
- If swComp.GetSuppression = 1 Or swComp.GetSuppression = 4 Then '零件压缩状态为轻化
- nRetval = swComp.SetSuppression2(2) '将轻化还原
- End If
- sCompName = swComp.GetPathName
-
- Set swCompModel = swApp.ActivateDoc2(sCompName, True, nRetval)
- Set swCompModel = swApp.ActiveDoc
- swCompPartName = swCompModel.GetTitle
- If swCompModel.GetType <> 1 Then
- MsgBox "请先在装配体中选择要改变标准件图标的零件!", vbCritical, "更改标准件标记 By Lunkay"
- End
- End If
- Set modelDocExt = swCompModel.Extension
- If BZJ = 1 Then '变成标准件图标
- If modelDocExt.ToolboxPartType <> 0 Then
- MsgBox "所选零件是标准件!请选择一个非标准件!", vbCritical, "更改标准件标记 By Lunkay"
- End
-
- Else
- modelDocExt.ToolboxPartType = 1
- swCompModel.Save
- End If
- ElseIf BZJ = 0 Then '变成零件图标
- If modelDocExt.ToolboxPartType = 0 Then
- MsgBox "所选零件不是标准件!", vbCritical, "更改标准件标记 By Lunkay"
- End
- Else
- modelDocExt.ToolboxPartType = 0
-
- swCompModel.Save
- End If
- End If
- End If
- Next n
- swModel.ClearSelection2 True
- Else
-
- MsgBox "请打开标装配体文件后再运行本程序!", vbCritical, "更改标准件标记 By Lunkay"
- End If
- End Sub
复制代码
|
评分
-
查看全部评分
|