还原零件颜色

505260187

   经典图书

网上有个随意改变颜色的宏，用完后零件变的五颜六色了。可以方便评审时对零件进行区分。但是如果想要还原颜色为材质原本设置的颜色。需要自行打开零件删除，有点麻烦。所以写了个零件颜色还原为原有材质的宏。有这种需求的可以下载试试。

lxr8833661

试用了，没成功，零件材质是都删除了，但没替换成原有材质

505260187

   经典图书

尴尬，有个bug，里面有个Ubound函数给写成Lbound了。
将改好后的宏从新给出。这次的没有密码。

补充内容 (2022-7-15 13:48):
从API帮助里面复制的一段获取材质数据路径的代码里面的bug
SOLIDWORKS API Help
Get Material Database Paths of Document Example (VBA)
This example shows how to get the paths and names of the material da...

xiaofly888

嗯 能用到。

505260187

   经典案例图书

Dim swApp               As SldWorks.SldWorks
Dim swModel             As SldWorks.ModelDoc2
Dim Components          As Variant
Dim SingleComponent     As Variant
Dim Ret                 As Variant
Dim swFeat              As SldWorks.Feature
Dim swSubFeat           As SldWorks.Feature
Dim dbs As Variant


Sub main()

    'On Error Resume Next
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    dbs = swApp.GetMaterialDatabases
    If swModel.GetType() = 1 Then                       '如果当前文件是零件
        ReturnColor swModel
    ElseIf swModel.GetType() = 2 Then                   '如果当前文件是装配体
        Components = swModel.GetComponents(False)
        For Each SingleComponent In Components
            Set swModel = SingleComponent.GetModelDoc()
            If swModel.GetType() = 1 Then
                ReturnColor swModel
                'MsgBox "子零件体"
            Else
            'MsgBox "子装配体"
            End If
        Next
    Else                                                '如果当前文件是工程图
        MsgBox "请打开一个零件或者装配体。"
    End If
   
End Sub

'将颜色应用原有材质的颜色
Public Function ReturnColor(swDoc As PartDoc)


Dim sMatDB As String, Material As String, sMaterialDB_path As String, Configuration_Name As String
    Set swFeat = swDoc.FirstFeature
    While Not swFeat Is Nothing
        swFeat.RemoveMaterialProperty
        Set swSubFeat = swFeat.GetFirstSubFeature
        While Not swSubFeat Is Nothing
            swSubFeat.RemoveMaterialProperty
            Set swSubFeat = swSubFeat.GetNextSubFeature
        Wend
        Set swFeat = swFeat.GetNextFeature
    Wend

Configuration_Name = swDoc.GetActiveConfiguration.Name
Material = swDoc.GetMaterialPropertyName2(Configuration_Name, sMatDB)

For i = 0 To UBound(dbs)
    If StrComp(Left(Right(dbs(i), Len(sMatDB) + 7), Len(sMatDB)), sMatDB) = 0 Then
        sMaterialDB_path = dbs(i)
    End If
Next i

'赋予零件材质默认的颜色
If Material <> "" Then
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, ""
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, Material
Else
    '下面这句是将没有赋予材质的零件的颜色删除，如果不想让给没有材质的零件删除颜色，可以注释掉这一句
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, ""
End If
    swDoc.EditRebuild
End Function

505260187

，有个位置写错了，Ubound写成Lbound了。重新发一下代码

505260187

   经典案例图书

Sub main()

    On Error Resume Next
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    dbs = swApp.GetMaterialDatabases
    If swModel.GetType() = 1 Then                       '如果当前文件是零件
        ReturnColor swModel
    ElseIf swModel.GetType() = 2 Then                   '如果当前文件是装配体
        Components = swModel.GetComponents(False)
        For Each SingleComponent In Components
            Set swModel = SingleComponent.GetModelDoc()
            If swModel.GetType() = 1 Then
                ReturnColor swModel
                'MsgBox "子零件体"
            Else
            'MsgBox "子装配体"
            End If
        Next
    Else                                                '如果当前文件是工程图
        MsgBox "请打开一个零件或者装配体。"
    End If
   
End Sub

'将颜色应用原有材质的颜色
Public Function ReturnColor(swDoc As PartDoc)


Dim sMatDB As String, Material As String, sMaterialDB_path As String, Configuration_Name As String
    Set swFeat = swDoc.FirstFeature
    While Not swFeat Is Nothing
        swFeat.RemoveMaterialProperty
        Set swSubFeat = swFeat.GetFirstSubFeature
        While Not swSubFeat Is Nothing
            swSubFeat.RemoveMaterialProperty
            Set swSubFeat = swSubFeat.GetNextSubFeature
        Wend
        Set swFeat = swFeat.GetNextFeature
    Wend

Configuration_Name = swDoc.GetActiveConfiguration.Name
Material = swDoc.GetMaterialPropertyName2(Configuration_Name, sMatDB)

For i = 0 To UBound(dbs)
    If StrComp(Left(Right(dbs(i), Len(sMatDB) + 7), Len(sMatDB)), sMatDB) = 0 Then
        sMaterialDB_path = dbs(i)
    End If
Next i

'赋予零件材质默认的颜色
If Material <> "" Then
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, ""
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, Material
Else
    '下面这句是将没有赋予材质的零件的颜色删除，如果不想让给没有材质的零件删除颜色，可以注释掉这一句
    swDoc.SetMaterialPropertyName2 Configuration_Name, sMaterialDB_path, ""
End If
    swDoc.EditRebuild
End Function
[/code]

jyzas001

谢谢分享

hhh001

感谢楼主分享，很不错！

自由设计

   经典图书

高手，密密麻麻的代码中u和l写错还能够发现。

zhych1982

楼主很专业，写得很好！

rialdfnu

感谢楼主分享，很不错！

iawifj

出现错误提示

whdong76

楼主辛苦了！

yh2008

加入QQ群
参与讨论和学习

或扫描二维码加入

如果是装配体有颜色，就无法删除了

周桃平

   经典案例图书

好好学习，天天向上！

周桃平

加入QQ群
参与讨论和学习

或扫描二维码加入

活到老学到老！

shibo106

   经典案例图书

楼主很专业，写得很好！

sunny_8848

多谢楼主热心分享

xiaomage25258

楼主很专业，写得很好！