Witam
Oto makro, które powinno być w stanie służyć jako punkt wyjścia, nie zapomnij zmodyfikować wiersza "databaseName = ... ", aby umieścić nazwę pliku sldmat .
Wszystkie pliki muszą być w trybie rozpoznania w zestawie.
Pozdrowienia
Option Explicit
Dim swApp As Object
Dim swModel As SldWorks.ModelDoc2
Dim myMatVisProps As SldWorks.MaterialVisualPropertiesData
Dim orgBlend As Boolean
Dim orgApply As Boolean
Dim orgAngle As Double
Dim orgScale As Double
Dim longstatus As Long
Dim bRet As Boolean
Dim i As Long
Dim Assembly As ModelDoc2
Dim myAssy As AssemblyDoc
Dim myCmps As Variant
Dim myCmp As Component2
Dim nInfo As Long
Sub main()
Set swApp = Application.SldWorks
Set Assembly = swApp.ActiveDoc
Set myAssy = Assembly
myCmps = myAssy.GetComponents(False)
For i = 0 To UBound(myCmps)
Set myCmp = myCmps(i)
If (myCmp.GetSuppression = 3) Or (myCmp.GetSuppression = 2) Then
bRet = myCmp.Select2(False, 0)
bRet = myAssy.EditPart2(True, True, nInfo)
Set swModel = myAssy.GetEditTarget
If swModel.GetType = 1 Then
Dim result As String
Dim Mat As String
Dim configName As String
configName = "Défaut"
Dim databaseName As String
databaseName = "C:/Program Files/SOLIDWORKS Corp/SOLIDWORKS/lang/french/sldmaterials/solidworks materials.sldmat"
Dim searchPropName1 As String
Dim searchPropName2 As String
Dim searchPropName3 As String
Dim searchPropName4 As String
searchPropName1 = "Soudure inox"
searchPropName2 = "Stellite Grade 21 (RC)"
searchPropName3 = "Stellite Grade 12 (RB)"
searchPropName4 = "Stellite Grade 6 (RA)"
Dim myPart As SldWorks.PartDoc
Set myPart = swModel
result = myPart.GetMaterialPropertyName2(configName, Mat)
If result = searchPropName1 Then
myPart.SetMaterialPropertyName2 configName, databaseName, searchPropName1
Set myMatVisProps = myPart.GetMaterialVisualProperties()
Call apply_material_visual_properties(myMatVisProps, myPart)
ElseIf result = searchPropName2 Then
myPart.SetMaterialPropertyName2 configName, databaseName, searchPropName2
Set myMatVisProps = myPart.GetMaterialVisualProperties()
Call apply_material_visual_properties(myMatVisProps, myPart)
ElseIf result = searchPropName3 Then
myPart.SetMaterialPropertyName2 configName, databaseName, searchPropName3
Set myMatVisProps = myPart.GetMaterialVisualProperties()
Call apply_material_visual_properties(myMatVisProps, myPart)
ElseIf result = searchPropName4 Then
myPart.SetMaterialPropertyName2 configName, databaseName, searchPropName4
Set myMatVisProps = myPart.GetMaterialVisualProperties()
Call apply_material_visual_properties(myMatVisProps, myPart)
End If
End If
myAssy.EditAssembly
End If
Next i
Assembly.ForceRebuild3 False
End Sub
Private Sub apply_material_visual_properties(myMatVisProps As SldWorks.MaterialVisualPropertiesData, myPart As SldWorks.PartDoc)
If Not myMatVisProps Is Nothing Then
orgAngle = myMatVisProps.Angle
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
orgScale = myMatVisProps.Scale2
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
If myMatVisProps.BlendColor = 0 Then
orgBlend = False
Else
orgBlend = True
End If
myMatVisProps.BlendColor = Not orgBlend
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
myMatVisProps.BlendColor = orgBlend
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
If myMatVisProps.ApplyMaterialColorToPart = 0 Then
orgApply = False
Else
orgApply = True
End If
myMatVisProps.ApplyMaterialColorToPart = Not orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
myMatVisProps.ApplyMaterialColorToPart = orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
If myMatVisProps.ApplyMaterialHatchToSection = 0 Then
orgApply = False
Else
orgApply = True
End If
myMatVisProps.ApplyMaterialHatchToSection = Not orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
myMatVisProps.ApplyMaterialHatchToSection = orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
If myMatVisProps.ApplyAppearance = 0 Then
orgApply = False
Else
orgApply = True
End If
myMatVisProps.ApplyAppearance = Not orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
myMatVisProps.ApplyAppearance = orgApply
longstatus = myPart.SetMaterialVisualProperties(myMatVisProps, swThisConfiguration, Nothing)
End If
End Sub
