求一个删除颜色宏

qq385629761 · 发表于 2025-3-2 20:46:22

对选中的零件或装配体的面的颜色进行清除移除外观操作保留材质原设定颜色

xxf8983 · 发表于 2025-3-3 10:52:37

顶一下，坐等高手！

jack11111 · 发表于 2025-3-3 11:02:05

经典图书

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

复制代码

qq385629761 · 发表于 2025-3-3 22:46:50

jack11111 发表于 2025-3-3 11:02

对选中面进行操作不所有的面

xiaozhe0581 · 发表于昨天 10:31

经典案例图书

很不错，顶一下！

		自动登录	找回密码
密码			立即注册

求一个删除颜色宏

浏览过的版块

最佳新人

活跃会员

宣传达人

热心会员

灌水之王

突出贡献