Materialien für Makro-Erscheinungsbilder

Maclane · 5. November 2025 um 11:15

Hallo;
Unter meinem Solidworks 2022 habe ich ein Makro erstellt, um die Erscheinungsbilder (die p2m-Dateien) meiner Materialien neu laden zu können.
Das Makro durchläuft die Baugruppen und löscht und ordnet alle Darstellungen der Materialien neu zu:

Option Explicit

Sub RechargerMatieresDansAssemblage()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAssembly As SldWorks.AssemblyDoc
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Or swModel.GetType <> swDocASSEMBLY Then
        MsgBox "Ouvrez un assemblage dans SolidWorks.", vbExclamation
        Exit Sub
    End If
    
    Set swAssembly = swModel
    
    ' Lancer la récursion sur tous les composants
    AppelRemontéeComposants swAssembly, Nothing
End Sub

' Fonction récursive pour traiter composants d’un assemblage
Sub AppelRemontéeComposants(asm As SldWorks.AssemblyDoc, parentComp As Object)
    Dim vComp As Variant
    Dim swComp As SldWorks.Component2
    Dim swModel As SldWorks.ModelDoc2
    Dim swPart As SldWorks.PartDoc
    
    vComp = asm.GetComponents(True) ' get tous composants, même cachés
    Dim i As Long
    For i = 0 To UBound(vComp)
        Set swComp = vComp(i)
        
        ' Essayer d’ouvrir le composant si ce n’est pas un sous-assemblage
        On Error Resume Next
        Set swModel = swComp.GetModelDoc2
        On Error GoTo 0
        
        If Not swModel Is Nothing Then
            If swModel.GetType = swDocPART Then
                ' Traiter la pièce
                Call RechargerMateriau(swModel)
            ElseIf swModel.GetType = swDocASSEMBLY Then
                ' Récursivité pour sous-assemblages
                Call AppelRemontéeComposants(swModel, swComp)
            End If
        End If
    Next i
End Sub

' Fonction pour recharger le matériau d’un modèle
Sub RechargerMateriau(swModel As SldWorks.ModelDoc2)
    Dim swPart As SldWorks.PartDoc
    Dim configName As String
    Dim databaseName As String
    Dim materialName As String
    
    Set swPart = swModel
        
If swModel.GetPathName() Like "*Bibl*" Then Exit Sub

    configName = swModel.ConfigurationManager.ActiveConfiguration.Name
    ' Récupérer le matériau actuel
    materialName = swPart.GetMaterialPropertyName2(configName, databaseName)
    
    Debug.Print "Composant en cours de traitement : " & swModel.GetTitle()
    
    If materialName <> "" Then
        ' Désaffecter le matériau puis le réaffecter pour forcer la recharge
        
        swModel.SetMaterialPropertyName2 "", "", ""
    Call swPart.SetMaterialPropertyName2(configName, databaseName, materialName)
        
        ' Rebuild et actualisation
        swModel.EditRebuild3
        swModel.GraphicsRedraw2
        Debug.Print "Matériau rechargé pour : " & swModel.GetPathName()
    End If
End Sub

Aber (es gibt immer ein " aber ") auf einigen Teilen wird zusätzlich zum Aussehen des Grundmaterials eine Erscheinungsbildüberlagerung angewendet, um unsere Vorstellungen von " wie gebaut " (wie gebaut) identifizieren zu können.

Im obigen Makro konnte ich die Komponenten mit diesen Erscheinungsbildern nicht identifizieren, um den Materialersatz (der diese " wie besehen " entfernt) nicht anzuwenden, ich möchte sie so belassen, wie sie sind.

Können Sie mir helfen?

Silver_Surfer · 5. November 2025 um 12:27

Hallo

Können Sie bitte angeben, auf welcher Ebene die TQC-Erscheinungsbilder betroffen sind?

Zimmerebene? (als Ersatz für das Erscheinungsbild des Materials)
Körperlich?
In Bezug auf die Funktion?
Auf Gesichtshöhe?
Komponenten-Ebene?

Maclane · 5. November 2025 um 12:48

Die überwiegende Mehrheit der Darstellungen des Bestands wirkt sich auf Komponentenebene aus.
Manchmal auf der Ebene des Körpers oder eines Gesichts, aber ich denke, es ist zunächst illusorisch, die API zu bitten, den kleinsten Teil des Raumes auf der Suche nach diesen Erscheinungen zu " scannen ".
Ich werde mich größtenteils mit einer Überprüfung der Komponente begnügen.

Maclane · 5. November 2025 um 13:11

Ich glaube, ich habe eine vielversprechende Spur gefunden:

sbadenis · 5. November 2025 um 13:18

Schauen Sie sich auch dieses Thema an:

Ich für meinen Teil hatte das Problem auf eine andere Weise umgangen (indem ich alles aus dem Gedächtnis anwendete)

Konti · 5. November 2025 um 13:35

Ja, das war's. Im Folgenden finden Sie einen schnellen C#-Code, der an den Anfang der ReloadMaterial-Methode gestellt wird

            Configuration swConfig = (Configuration)swModel.GetActiveConfiguration();
            object[] displayStateNames = (object[])swConfig.GetDisplayStates();
            object[] b = (object[])swModel.Extension.GetRenderMaterials2(2, displayStateNames);
            foreach (object c in b)
            {
                IRenderMaterial d = c as IRenderMaterial;
                if(d != null)
                {
                    Debug.Print(d.FileName.ToString());
                    if (d.FileName.Contains("TQC"))
                        return;
                }
            }

Konti · 5. November 2025 um 13:37

Übersetzung durch chatGPT muss natürlich angepasst und überprüft werden

Sub CheckRenderMaterials()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swConfig As SldWorks.Configuration
    Dim displayStateNames As Variant
    Dim renderMats As Variant
    Dim vMat As Variant
    Dim swRenderMat As SldWorks.RenderMaterial

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then Exit Sub

    ' Récupère la configuration active
    Set swConfig = swModel.GetActiveConfiguration
    If swConfig Is Nothing Then Exit Sub

    ' Récupère les états d'affichage
    displayStateNames = swConfig.GetDisplayStates

    ' Récupère les matériaux de rendu
    renderMats = swModel.Extension.GetRenderMaterials2(2, displayStateNames)

    ' Parcourt les matériaux
    For Each vMat In renderMats
        Set swRenderMat = vMat
        If Not swRenderMat Is Nothing Then
            Debug.Print swRenderMat.FileName
            If InStr(1, swRenderMat.FileName, "TQC", vbTextCompare) > 0 Then
                Exit Sub ' équivalent de return
            End If
        End If
    Next vMat

End Sub

Maclane · 5. November 2025 um 13:59

Vielen Dank für Ihre Teilnahme, aber in meinem Fall verwende ich keine Anzeigezustände, aber es eröffnet andere Arbeitsmöglichkeiten.

Indem ich mich auf das Makro "Delete Appearance Example (VBA)" der Solidworks-Hilfe verließ, gelang es mir, ein Makro zu entwickeln, das meinen Anforderungen gut zu entsprechen scheint.

Auf der anderen Seite, seien Sie nachsichtig, es ist roh aus der Gießerei und Sie werden einige Funktionen und Aussagen entgraten und neu bohren müssen (professionelle Verformung), um es bekömmlicher zu machen:

Option Explicit

Sub RechargerMatieresDansAssemblage()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAssembly As SldWorks.AssemblyDoc
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Or swModel.GetType <> swDocASSEMBLY Then
        MsgBox "Ouvrez un assemblage dans SolidWorks.", vbExclamation
        Exit Sub
    End If
    
    Set swAssembly = swModel
    
    ' Lancer la récursion sur tous les composants
    AppelRemontéeComposants swAssembly, Nothing
End Sub

' Fonction récursive pour traiter composants d’un assemblage
Sub AppelRemontéeComposants(asm As SldWorks.AssemblyDoc, parentComp As Object)
    Dim vComp As Variant
    Dim swComp As SldWorks.Component2
    Dim swModel As SldWorks.ModelDoc2
    Dim swPart As SldWorks.PartDoc
    
    vComp = asm.GetComponents(True) ' get tous composants, même cachés
    Dim i As Long
    For i = 0 To UBound(vComp)
        Set swComp = vComp(i)
        
        ' Essayer d’ouvrir le composant si ce n’est pas un sous-assemblage
        On Error Resume Next
        Set swModel = swComp.GetModelDoc2
        On Error GoTo 0
        
        If Not swModel Is Nothing Then
            If swModel.GetType = swDocPART Then
                ' Traiter la pièce
                Call RechargerMateriau(swModel)
            ElseIf swModel.GetType = swDocASSEMBLY Then
                ' Récursivité pour sous-assemblages
                Call AppelRemontéeComposants(swModel, swComp)
            End If
        End If
    Next i
End Sub

' Fonction pour recharger le matériau d’un modèle
Sub RechargerMateriau(swModel As SldWorks.ModelDoc2)
    Dim swPart As SldWorks.PartDoc
    Dim configName As String
    Dim databaseName As String
    Dim materialName As String
    
    Set swPart = swModel
        
If UCase(swModel.GetPathName()) Like "*BIBL*" Then Exit Sub

    configName = swModel.ConfigurationManager.ActiveConfiguration.Name
    ' Récupérer le matériau actuel
    materialName = swPart.GetMaterialPropertyName2(configName, databaseName)
    Debug.Print "---------------------------------------------------------------"
    Debug.Print "---------------------------------------------------------------"
    Debug.Print "Composant en cours de traitement : " & swModel.GetTitle()
    
    If materialName <> "" Then
        ' Désaffecter le matériau puis le réaffecter pour forcer la recharge
        
     '*****************************************************************
 'Contrôle de l'apparence au niveau du composant pour eviter de remplacer les apparences "TQC"
 
     ' Get the render materials
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swSelMgr As SldWorks.SelectionMgr
Dim swRenderMaterial As SldWorks.RenderMaterial
Dim varRenderMaterial As Variant
Dim vRenderMaterial As Variant
Dim NomApparence As String
Dim ApparenceCount As Long, ApparenceID As Long
Dim boolstatus As Boolean

Set swSelMgr = swModel.SelectionManager
Set swModelDocExt = swModel.Extension

ApparenceCount = swModelDocExt.GetRenderMaterialsCount
Debug.Print "Quantité d'apparence trouvées: " & ApparenceCount
varRenderMaterial = swModelDocExt.GetRenderMaterials

NomApparence = ""

For Each vRenderMaterial In varRenderMaterial
    Set swRenderMaterial = vRenderMaterial
    ApparenceID = swRenderMaterial.MaterialID
    'Debug.Print "Appearance ID: " & ApparenceID
    NomApparence = swRenderMaterial.FileName
    Debug.Print "Appearance filename: " & NomApparence
    
        If UCase(NomApparence) Like "*TQC*" Then Exit Sub
    
    swModelDocExt.UpdateRenderMaterialsInSceneGraph True
Next

 '*****************************************************************
        swModel.SetMaterialPropertyName2 "", "", ""
    Call swPart.SetMaterialPropertyName2(configName, databaseName, materialName)
        
        ' Rebuild et actualisation
        swModel.EditRebuild3
        swModel.GraphicsRedraw2
        Debug.Print "Matériau rechargé pour : " & swModel.GetPathName()
    End If
End Sub

Und das ist das einzige Mal, dass ich die Hilfe von KIs annehme, um meine Makros neu zu strukturieren und zu kommentieren...