SW API; Subfolder macro: retrieve file properties from ss-folders

Macro
1

Hello

I found several posts in various forums but I can't do it...

The following macro, derived from several pieces of code, exports the Description, Number and Reference properties of SLDPRT files to an excel.

However, the macro doesn't go in the subfolders and I can't seem to go there!

Would someone be kind enough to help me complete the code?

Thanks in advance,

 

 

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")
filename = InputBox("filename: ")
filename = filename & ".csv"
Set a = fs. CreateTextFile("C:\Users\***********\Desktop\" & filename, True)

Visibility = swApp.DocumentVisible(False, swDocPART)
a.writeline ("Number" & ";" & "Description" & ";" & "Reference")

'Choice folder + .sldprt file recovery

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

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

FileName = Dir(Currentpath & "*.sldprt")
End of phase


Do While FileName <> ""
Set Part = swApp.OpenDoc(Currentpath & FileName, swDocPART)
Description = Part.GetCustomInfoValue("", "Description")
Number = Part.GetCustomInfoValue("", "Number")
Reference = Part.GetCustomInfoValue("", "reference")
a.writeline (Number&";" & Description &";" & Reference)
swApp.CloseDoc FileName
FileName = Dir
Loop

Visibility = swApp.DocumentVisible(True, swDocPART)

End Sub
 

2

I found another macro that helps me a little more. But I'm facing a new problem: Automation error: the invoked object has disconnected from its clients.

debugging shows the line:  Set Part = swApp.OpenDoc(File, swDocPART)

Basically, the macro lists what I need by opening and closing the pieces one by one, and then I export the list.

However, sometimes (often) it crashes in class... If anyone sees where this error can come from...

3

Hello

Here is an example of code, be careful it will not work if a file other than a sldprt is found in the file list, you must add a check on the file type before opening it in 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

Kind regards