AnsweredAssumed Answered

Delete appearance of imported *.step parts

Question asked by Patrick Krug on May 28, 2019
Latest reply on May 28, 2019 by Artem Taturevych

Hi everyone,

I wrote a macro to set the appearance of a part or assembly.

The problem is, I don't know how to delete the appearance of the

'Importiert1' feature in an imported *.step part.

 

 

And until I delete this color ( in this case 'white' ) by hand it won't

change to the desired ( in this case 'red' ) color.

 

Dim swApp As SldWorks.SldWorks
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swAppearance As SldWorks.RenderMaterial
Dim swModel As SldWorks.ModelDoc2
Dim boolstatus As Boolean
Dim msgBox1 As Boolean
Dim strColor As String
Dim strColorPath As String
Dim renderMat As String
Dim materialID1 As Long
Dim materialID2 As Long
Const strFolderPath As String = "G:\Konstruktion\_Ablagen\Ablage_Patrick Krug\02. Arbeit\02.02. Solidworks\02.02.01. Makro\02.02.01.01. Erscheinungsbilder\" 'Pfad der Erscheinungsbilder

Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Ignoriere nichts
If swModel Is Nothing Then Exit Sub

Set swModelDocExt = swModel.Extension

'Ignoriere Zeichnungen
If (swModel.GetType() = swDocumentTypes_e.swDocDRAWING) Then Exit Sub

'Lese "Farbe" aus Eigenschaften
strColor = swModel.GetCustomInfoValue(Standard, "Farbe")

'Überprüfen ob im Feld "Farbgebung" etwas eingetragen ist
If Len(strColor) = 0 Then
MsgBox "Keine Farbe eingetragen", vbOKOnly + vbInformation, "Farbe" 'kann entfallen
Exit Sub
End If

Debug.Print "strColor : " & strColor

'Frage bei MBG's, Zukauf und Beistellung Kunde
If swModel.GetCustomInfoValue(Standard, "Bemerkung") = "MBG" Or swModel.GetCustomInfoValue(Standard, "Bemerkung") = "Zukauf" Or swModel.GetCustomInfoValue(Standard, "Bemerkung") = "Beistellung Kunde" Then

msgBox1 = MsgBox("Sind sie sicher, dass sie diesem Teil eine Farbe zuweisen möchten? - Bemerkung: " & swModel.GetCustomInfoValue(Standard, "Bemerkung"), vbYesNo + vbInformation, "SolidWorks")

If msgBox1 = vbYes Then Call setAppearance
If msgBox1 = vbNo Then Exit Sub
End If

Call setAppearance
End Sub

Sub setAppearance()
'Leerzeichen vor und hinter dem String entfernen
strColor = LTrim(RTrim(strColor))

'Überprüfen ob RAL- oder Sonderfarbe
If (Left(strColor, 3) = "RAL") Then
strColor = Left(strColor, 8)
End If

'strColor wird der Pfad und die Endung "*.p2m" angefügt
strColorPath = strFolderPath & strColor + ".p2m"

Debug.Print "strColorPath : " & strColorPath

'If color exists
If FileExists(strColorPath) Then
'####### Here the color has to be removed!

Set swAppearance = swModelDocExt.CreateRenderMaterial(strColorPath)
swAppearance.AddEntity swModel
swModelDocExt.AddRenderMaterial swAppearance, 0
Exit Sub
Else
MsgBox "Überprüfe deine Eingabe! Oder das Erscheinungsbild ist noch nicht vorhanden!", vbExclamation + vbOKOnly, "Error"
End If
End Sub

'Funktion überprüft ob eine Datei (hier z.B.: RAL 7035.p2m) existiert - Quelle: www.dbwiki.net oder www.dbwiki.de
Function FileExists(ByVal Dateipfad As String) As Boolean
FileExists = CreateObject("Scripting.FileSystemObject").FileExists(Dateipfad)
End Function

 

I hope anyone can help me, maybe i'm just thinking to complicated

( I attached the code in the attachments too )

 

Greetings Patrick 

Outcomes