Materiały o wyglądzie makro

Maclane · 5 Listopad 2025 11:15

Witam;
W moim Solidworks 2022 utworzyłem makro, aby móc ponownie załadować wyglądy (pliki p2m) moich materiałów.
Makro przechodzi przez zespoły oraz usuwa i ponownie przypisuje wszystkie wyglądy materiałów:

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

Ale (zawsze jest " ale ") na niektórych częściach, oprócz wyglądu materiału podstawowego, nakładka wyglądu jest nakładana, aby móc zidentyfikować nasze pojęcia " powykonawcze " (powykonawcze).

W powyższym makrze nie mogłem zidentyfikować komponentów o takim wyglądzie, aby nie zastosować zamiennika materiału (który usunie te " tak jak są "), chcę je zachować takimi, jakimi są.

Czy mógłbyś mi pomóc?

Silver_Surfer · 5 Listopad 2025 12:27

Witam

Czy może Pan/Pani określić, na jakim poziomie dotyczy to występowania TQC?

Poziom pokoju? (jako substytut wyglądu materiału)
Ciało?
Pod względem funkcji?
Na poziomie twarzy?
Poziom komponentu?

Maclane · 5 Listopad 2025 12:48

Zdecydowana większość wyglądów powykonawczych jest zaburzona na poziomie komponentu.
Czasami na poziomie ciała lub twarzy, ale myślę, że na początku iluzoryczne jest proszenie API o " przeskanowanie " najmniejszej części pomieszczenia w poszukiwaniu tych pozorów.
W większości przypadków zadowolę się sprawdzeniem komponentu.

Maclane · 5 Listopad 2025 13:11

Myślę, że znalazłem obiecujący trop:

sbadenis · 5 Listopad 2025 13:18

Spójrz również na ten temat:

Ze swojej strony obszedłem problem w inny sposób (stosując się do wszystkiego z pamięci)

Konti · 5 Listopad 2025 13:35

Tak, to wszystko. Oto krótki kod w języku C#, który należy umieścić na początku metody ReloadMaterial

            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 Listopad 2025 13:37

Tłumaczenie przez chatGPT oczywiście do dostosowania i sprawdzenia

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 Listopad 2025 13:59

Dziękuję za udział, ale w moim przypadku nie używam stanów wyświetlania, ale otwiera to inne ścieżki pracy.

Opierając się na makrze "Usuń przykład wyglądu (VBA)" z pomocy Solidworks, udało mi się wymyślić makro, które wydaje się dobrze spełniać moje potrzeby.

Z drugiej strony, bądź pobłażliwy, jest surowy z odlewni i będziesz musiał gratować i ponownie wiercić (profesjonalne odkształcenie) niektóre funkcje i stwierdzenia, aby był bardziej strawny:

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

I to jest jedyny moment, kiedy akceptuję pomoc sztucznej inteligencji w restrukturyzacji i komentowaniu moich makr...