Macro Uiterlijk Materialen

[Maclane]

Hallo;
Onder mijn Solidworks 2022 heb ik een macro gemaakt om de appearances (de p2m-bestanden) van mijn materialen opnieuw te kunnen laden.
De macro doorkruist de assemblages en verwijdert en wijst alle verschijningsvormen van de materialen toe:

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

Maar (er is altijd een " maar ") op sommige delen wordt, naast het uiterlijk van het basismateriaal, een uiterlijke overlay aangebracht om onze noties van " as-built " (as-built) te kunnen identificeren.

In de macro hierboven kon ik de componenten met deze verschijningen niet identificeren om de materiaalvervanging niet toe te passen (die deze " as-is " zal verwijderen), ik wil ze houden zoals ze zijn.

Kunnen jullie me helpen?

[Silver_Surfer]

Hallo

Kunt u aangeven op welk niveau de TQC-optredens worden beïnvloed?

• Kamerniveau? (als vervanging voor het uiterlijk van het materiaal)
• Qua lichaam?
• Qua functie?
• Gezicht niveau?
• Component niveau?

[Maclane]

De overgrote meerderheid van de as-built verschijningen wordt beïnvloed op componentniveau.
Soms op het niveau van het lichaam of een gezicht, maar ik denk dat het in eerste instantie een illusie is om de API te vragen om het kleinste deel van de kamer te " scannen " op zoek naar deze verschijningen.
Ik zal voor het grootste deel tevreden zijn met een controle van het onderdeel.

[Maclane]

Ik denk dat ik een veelbelovende aanwijzing heb gevonden:

Welkom bij de SOLIDWORKS Web Help

[sbadenis]

Kijk ook eens naar dit onderwerp:

API -Solidworks Verwijder (verwijder) een verschijning op basis van de naam

Bedankt voor de @mandragore track, maar voor nu snap ik de naam niet. Er is iets dat me ontgaat... Ik voeg de gemodificeerde code toe en test de assemblage voor het geval iemand van jullie meer geïnspireerd is.     Optie Expliciet: Dim swApp als SldWorks.SldWorks Dim swModel als SldWorks.ModelDoc2 Dim swConfig als SldWorks.Configuration Dim swModelDocExt als SldWorks.ModelDocExtension Dim swEntity als SldWorks.Entity Zon swSelMgr Als SldWorks.SelectionMgr Dim swRenderMaterial Als SldWorks.RenderMaterial Di...

Van mijn kant had ik het probleem op een andere manier omzeild (door alles uit het geheugen toe te passen)

[Konti]

Ja, dat is het. Hier is een korte C#-code die u aan het begin van uw ReloadMaterial-methode kunt plaatsen

            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]

Vertaling door chatGPT moet natuurlijk worden aangepast en gecontroleerd

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]

Bedankt voor je deelname, maar in mijn geval gebruik ik geen weergavestatussen, maar het opent andere werkwegen.

Door te vertrouwen op de macro "Delete Appearance Example (VBA)" van de Solidworks-hulp, ben ik erin geslaagd een macro te bedenken die goed aan mijn behoeften lijkt te voldoen.

Aan de andere kant, wees toegeeflijk, het is rauw van de gieterij en je zult enkele functies en uitspraken moeten ontbramen en opnieuw boren (professionele vervorming) om het beter verteerbaar te maken:

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

En dit is de enige keer dat ik de hulp van AI's accepteer om mijn macro's te herstructureren en te becommentariëren...