SW API; Macro sous-dossier: récupérer les propriétés des fichiers des ss-dossiers

Macro
1

Bonjour,

j'ai trouvé plusieurs posts dans divers forum mais je n'y arrive pas ...

La macro ci-après, issue de plusieurs bouts de codes, exporte les propriétés Description, Numéro et Référence des fichiers SLDPRT dans un excel.

Cependant, la macro ne va pas dans les sous-dossiers et je n'arrive pas à y aller ! 

Quelqu'un aurait-il l'amabilité de m'aider à compléter le code ?

Merci d'avance,

 

 

Dim Part As SldWorks.ModelDoc2
Dim a As Object
Dim fs As Object
Dim Currentpath As String
Dim Subfolder As Object


Function SelectFolder(Optional Title As String, Optional TopFolder As String) As String

    Dim objShell As New Shell32.Shell
    Dim objFolder As Shell32.Folder

'If you use 16384 instead of 1 on the next line, files are also displayed

    Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)
    If Not objFolder Is Nothing Then

        SelectFolder = objFolder.Items.Item.Path

    End If

End Function

Sub main()

Set swApp = Application.SldWorks

Set fs = CreateObject("Scripting.FileSystemObject")
nomfichier = InputBox("nom du fichier: ")
nomfichier = nomfichier & ".csv"
Set a = fs.CreateTextFile("C:\Users\***********\Desktop\" & nomfichier, True)

Visibility = swApp.DocumentVisible(False, swDocPART)
a.writeline ("Numéro" & ";" & "Description" & ";" & "Référence")

'choix dossier + récupération fichier .sldprt

Currentpath = SelectFolder("Select Folder", "")

If Currentpath = "" Then
End If
Currentpath = Currentpath & "\"

FileName = Dir(Currentpath & "*.sldprt")
'fin de phase


Do While FileName <> ""
    Set Part = swApp.OpenDoc(Currentpath & FileName, swDocPART)
    Description = Part.GetCustomInfoValue("", "Description")
    Numéro = Part.GetCustomInfoValue("", "Numéro")
    Référence = Part.GetCustomInfoValue("", "référence")
    a.writeline (Numéro & ";" & Description & ";" & Référence)
    swApp.CloseDoc FileName
    FileName = Dir
Loop

Visibility = swApp.DocumentVisible(True, swDocPART)

End Sub
 

2

J'ai trouvé une autre macro qui m'aide un peu plus. Mais je suis confronté à un nouveau problème: Erreur Automation: l'objet invoqué s'est déconnecté de ses clients.

le débogage montre la ligne:  Set Part = swApp.OpenDoc(File, swDocPART)

En gros, la macro dresse la liste de ce que j'ai besoin en ouvrant et fermant les pièces une par une, puis j'exporte la liste.

Cependant, des fois (souvent), ça plante en cours ... Si quelqu'un voit d'où peut venir cette erreur ...

3

Bonjour,

Voici un exemple de code, attention celui-ci ne fonctionnera pas si un fichier autre qu'un sldprt est trouvé dans la liste de fichier, il faut ajouter une vérification sur le type de fichier avant de l'ouvrir dans SW :

'Outils | Références : Cocher Microsoft Scripting Runtime

Option Explicit

Dim swApp As Object
Dim part As ModelDoc2

Dim maListe() As String
Dim FileName As String
Dim Description As String
Dim Numéro As String
Dim Référence As String
Dim i As Integer
Dim j As Integer

Const DossierRacine As String = "C:\Nouveau dossier"

Sub main()
    Set swApp = Application.SldWorks
    
    ReDim maListe(0 To 1)
    j = 0
    
    ListeFichiers DossierRacine, True
    
    For i = 0 To UBound(maListe) - 1
        FileName = maListe(i)
        Set part = swApp.OpenDoc(FileName, swDocPART)
        Description = part.GetCustomInfoValue("", "Description")
        Numéro = part.GetCustomInfoValue("", "Numéro")
        Référence = part.GetCustomInfoValue("", "référence")
        
        MsgBox Numéro & ";" & Description & ";" & Référence
        
        swApp.CloseDoc FileName
    Next i
End Sub

Private Sub ListeFichiers(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
    Dim FSO As Scripting.FileSystemObject
    Dim DossierSource As Scripting.Folder
    Dim SousDossier As Scripting.Folder
    Dim Fichier As Scripting.File
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
    
    For Each Fichier In DossierSource.Files
        maListe(j) = Fichier.ParentFolder & "\" & Fichier.Name
        j = j + 1
        ReDim Preserve maListe(0 To j)
    Next Fichier
     
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If
     
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub

Cordialement,