更改装配体特征树标准件图标——更新适用2014——2017 - iCAx开思网

' ------------------------------------------------------------------------------
' 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

复制代码

' ------------------------------------------------------------------------------
' ChangeToolboxPartProperty
' 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

复制代码