求一个删除颜色宏 - SolidWorks机械工程师网——最大的SolidWorks学习平台

Option Explicit
Sub Main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swComp As SldWorks.Component2
Dim vBodies As Variant
Dim vComps As Variant
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
Select Case swModel.GetType
Case swDocumentTypes_e.swDocPART
' 处理零件文件
Set swPart = swModel
vBodies = swPart.GetBodies2(swBodyType_e.swAllBodies, True)
If Not IsEmpty(vBodies) Then
For i = 0 To UBound(vBodies)
Dim swBody As SldWorks.Body2
Set swBody = vBodies(i)
' 清除实体颜色覆盖
swBody.SetMaterialPropertyName ""
swBody.ClearBodyColor
Next
End If
' 清除所有面颜色覆盖
ClearFaceColors swModel
Case swDocumentTypes_e.swDocASSEMBLY
' 处理装配体文件
vComps = swModel.GetComponents(True)
If Not IsEmpty(vComps) Then
For i = 0 To UBound(vComps)
Set swComp = vComps(i)
Set swModel = swComp.GetModelDoc2
If Not swModel Is Nothing Then
' 递归处理子组件
ClearFaceColors swModel
swModel.ForceRebuild3 True
End If
Next
End If
End Select
' 刷新视图
swModel.GraphicsRedraw2
MsgBox "颜色覆盖已清除！", vbInformation
Else
MsgBox "请打开一个零件或装配体文件！", vbExclamation
End If
End Sub
' 清除所有面的颜色覆盖
Sub ClearFaceColors(model As SldWorks.ModelDoc2)
Dim swFace As SldWorks.Face2
Dim swEntity As SldWorks.Entity
Dim swModelExt As SldWorks.ModelDocExtension
Set swModelExt = model.Extension
' 遍历所有面并清除颜色
Set swEntity = model.FirstFace
While Not swEntity Is Nothing
Set swFace = swEntity
swFace.SetFaceColor Nothing ' 清除面颜色覆盖
Set swEntity = swEntity.GetNextFace
Wend
' 清除全局实体颜色覆盖
swModelExt.ClearEntityColor swColorEntityType_e.swColorFaces
swModelExt.ClearEntityColor swColorEntityType_e.swColorBodies
End Sub

复制代码