Omdat ik er niet in slaagde om via API's een betrouwbare oplossing te vinden, heb ik een macro ontwikkeld.
Het doorloopt de boomstructuur (met de subniveaus) en exporteert vervolgens een html-rapport.
Hier is de code voor degenen die het willen.
Option Explicit
'U:\Bibliothèque\Equipements\Encaisseuses\Picking\Spécifiques\MSG N°194-MSG COMPACT DUAL M3R2\1-Dessins\AS_111792.SLDASM
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim k As Integer
Dim dictionary As Object
Dim Values As clsObject
Dim CompModel As ModelDoc2
Dim Ret As Boolean
Dim htmlPath As String
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent
Set dictionary = CreateObject("Scripting.Dictionary")
TraverseComponentRecherchePropriete swRootComp, 1
'Lecture du Dictionnaire:
Dim TestvaleurDico As Variant
'Debug.Print dictionary.count
If dictionary.count <> 0 Then
'Création du fichier html
Dim xFile As Integer
Dim S1 As String
xFile = FreeFile
'Emplacement de sauvegarde des options
htmlPath = Environ("USERPROFILE") & "\.Rapports_SW\"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
If Dir(htmlPath, vbDirectory + vbHidden) = "" Then
MkDir htmlPath
End If
Open htmlPath & "RapportIndiçage.html" For Output As xFile
Print #xFile, "<HTML>"
Print #xFile, "<HEAD>"
Print #xFile, "<TITLE>Liste fichiers</TITLE>"
Print #xFile, "</HEAD>"
Print #xFile, ""
Print #xFile, "<BODY TEXT=""#000000"" >"
Print #xFile, " <h1><B>Liste des fichiers indicés à remplacer</B> </h1>"
Print #xFile, "<BR><BR>"
For Each TestvaleurDico In dictionary.Keys
'<a href="file:///D:/doc/monfichier.pdf">monfichier</a>
Print #xFile, "Nom: " & TestvaleurDico & "-> Désignation: " & dictionary(TestvaleurDico).Designation
Print #xFile, "<BR><BR>"
Print #xFile, "Chemin: " & dictionary(TestvaleurDico).Chemin
Print #xFile, "<BR><BR>"
Next TestvaleurDico
Print #xFile, "<BR><BR>"
Print #xFile, "</BODY>"
Print #xFile, "</HTML>"
Close xFile
'Ouvre le fichier html
Ret = ShellExecute(0, "open", "RapportIndiçage.html", vbNullString, htmlPath, 1)
End If
Set TestvaleurDico = Nothing
Set dictionary = Nothing
End Sub
Sub TraverseComponentRecherchePropriete(swComp As SldWorks.Component2, nLevel As Long)
Dim vChildComp As Variant
Dim swModelComponent As SldWorks.ModelDoc2
Dim swChildComp As SldWorks.Component2
Dim swCompConfig As SldWorks.Configuration
Dim myBool As String
Dim sPadStr As String
Dim i As Long
Dim Part As SldWorks.ModelDoc2
Dim Propriete As String
For i = 0 To nLevel - 1
sPadStr = sPadStr + " "
Next i
vChildComp = swComp.GetChildren
Propriete = "Designation"
For i = 0 To UBound(vChildComp)
Set swChildComp = vChildComp(i)
Set swModelComponent = swChildComp.GetModelDoc
TraverseComponentRecherchePropriete swChildComp, nLevel + 1 'multi niveau
'Debug.Print "Name2 : " & swChildComp.Name2 & vbCrLf & "ReferencedConfiguration: " & swChildComp.ReferencedConfiguration
boucle "Designation", "", "", "", swModelComponent, swChildComp.ReferencedConfiguration, swChildComp
Next i
End Sub
Sub boucle(Propriete, proprieteTab, proprieteTab_Prop, t, swModelComponent, swChildCompRC, swChildComp)
If Not swModelComponent Is Nothing Then
'Debug.Print swModelComponent.GetCustomInfoValue("", Propriete)
Set CompModel = swChildComp.GetModelDoc2
If InStr(swModelComponent.GetCustomInfoValue("", Propriete), "Remplac") > 1 Then
Set Values = New clsObject
Values.Chemin = swChildComp.GetPathName()
'Values.Nom = swChildComp.Name2
Values.Designation = swModelComponent.GetCustomInfoValue("", Propriete)
If dictionary.Exists(CompModel.GetTitle) Then
Set dictionary(CompModel.GetTitle) = Values
Else
dictionary.Add CompModel.GetTitle, Values
End If
'Debug.Print swChildComp.Name2
'Debug.Print CompModel.GetTitle
'Debug.Print swChildComp.GetPathName()
'Debug.Print swModelComponent.GetCustomInfoValue("", Propriete)
End If
If InStr(swModelComponent.GetCustomInfoValue(swChildCompRC, Propriete), "Remplac") > 1 Then
Set Values = New clsObject
Values.Chemin = swChildComp.GetPathName()
'Values.Nom = swChildComp.Name2
Values.Designation = swModelComponent.GetCustomInfoValue(swChildCompRC, Propriete)
If dictionary.Exists(CompModel.GetTitle) Then
Set dictionary(CompModel.GetTitle) = Values
Else
dictionary.Add CompModel.GetTitle, Values
End If
'Debug.Print swChildComp.Name2
'Debug.Print swChildComp.GetPathName()
'Debug.Print swModelComponent.GetCustomInfoValue("", Propriete)
End If
End If
End Sub
'Public Chemin As String, Designation As String, Nom As String
Sub AddValues()
For k = 2 To 3
Set Values = New clsPerson
Values.Chemin = "Chemin"
Values.Designation = "Designation"
'Values.Nom = "Nom"
If dictCompany.Exists(k) Then
Set dictCompany(k) = Values
Else
dictCompany.Add k, Values
End If
Next k
End Sub
En de class module (Te noemen clsObject):
Public Chemin As String, Designation As String ', Nom As String
Bedankt @Maclane voor de voorstellen en de bevestiging van de bug, die me afleidde van mijn 1e idee.
