Bonjour;
Sous mon Solidworks 2022 j’ai créé une macro pour pouvoir recharger les apparences (les fichiers p2m) de mes matériaux.
La macro parcours les assemblages et Supprime puis Réaffecte toutes les apparences des matériaux:
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
Mais (il y a toujours un « mais ») sur certaines pièces, en plus de l’apparence du matériau de base, est appliqué une surcouche d’apparence pour pouvoir identifier nos notions de « TQC » (Tel Que Construit).
Dans la macro ci-dessus je na parviens pas à identifier les composants avec ces apparences pour ne pas appliquer le remplacement du Matériau (qui supprimerai ces « TQC »), je souhaite les conserver tel-quel.
Les apparences TQC sont dans la plus grande majorité affectée au niveau du composant.
Parfois au niveau du corps ou d’une face mais je pense qu’il est illusoire, dans un premier temps, de demander à l’API de « scanner » la moindre parcelle de la pièce à la recherche de ces apparences.
Je me contenterai, très largement, d’une vérification sur le composant.
Oui c’est ça. Voici un code vite fait en C# à mettre au début de ta méthode RechargerMateriau
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;
}
}
Traduction par chatGPT à adapter et vérifier bien sûr
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
Merci pour votre participation, mais dans mon cas je n’utilise pas les états d’affichages cependant cela ouvre d’autres pistes de travail.
En m’appuyant sur la macro " Delete Appearance Example (VBA)" de l’aide Solidworks j’ai réussi à pondre une macro qui semble bien répondre à mon besoin.
Par contre, soyez indulgents, elle est brute de fonderie et il vas falloir ébavurer et réaléser (déformation professionnelle) quelques fonctions et déclarations pour la rendre plus digeste:
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
Et c’est bien le seul moment où j’accepte l’aide des IA pour restructurer et commenter mes macro…
