SW-API; Unterordner-Makro: Abrufen von Dateieigenschaften aus ss-folders

Macro
1

Hallo

Ich habe mehrere Beiträge in verschiedenen Foren gefunden, aber ich kann es nicht...

Das folgende Makro, das aus mehreren Codeteilen abgeleitet ist, exportiert die Eigenschaften Description, Number und Reference von SLDPRT-Dateien in eine Excel-Datei.

Das Makro geht jedoch nicht in die Unterordner und ich kann anscheinend nicht dorthin gehen!

Wäre jemand so freundlich, mir bei der Fertigstellung des Codes zu helfen?

Danke im Voraus,

 

 

Dimmen des Teils als SldWorks.ModelDoc2
Dimmen Sie ein als Objekt
Dim fs Als Objekt
Dimmen Sie den Strompfad als Zeichenfolge
Unterordner als Objekt dimmen


Funktion SelectFolder(Optional Title As String, Optional TopFolder As String) Als String

Dim objShell als neue Shell32.Shell
Dim objFolder As Shell32.Folder

'Wenn Sie in der nächsten Zeile 16384 anstelle von 1 verwenden, werden auch Dateien angezeigt

Set objFolder = objShell.BrowseForFolder(0, Titel, 1, TopFolder)
Wenn nicht, ist objFolder nichts, dann

SelectFolder = objFolder.Items.Item.Path

Ende, wenn

Ende-Funktion

Sub main()

Legen Sie swApp = Application.SldWorks fest

Set fs = CreateObject("Scripting.FileSystemObject")
filename = InputBox("Dateiname: ")
filename = Dateiname & ".csv"
Legen Sie a = fs fest. CreateTextFile("C:\Benutzer\***********\Desktop\" & Dateiname, True)

Sichtbarkeit = swApp.DocumentVisible(Falsch, swDocPART)
a.writeline ("Anzahl" & ";" & "Beschreibung" & ";" & "Referenz")

'Auswahlordner + Wiederherstellung von .sldprt-Dateien

Currentpath = SelectFolder("Ordner auswählen", "")

if currentpath = "" dann
Ende, wenn
Currentpath = Currentpath & "\"

Dateiname = Verzeichnis(Aktueller Pfad & "*.sldprt")
Ende der Phase


Ausführen, während Dateiname <> ""
Set Part = swApp.OpenDoc(Currentpath & FileName, swDocPART)
Beschreibung = Part.GetCustomInfoValue("", "Beschreibung")
Zahl = Part.GetCustomInfoValue("", "Zahl")
Referenz = Part.GetCustomInfoValue("", "Referenz")
a.writeline (Anzahl&";" & Beschreibung &";" & Referenz)
swApp.CloseDoc Dateiname
Dateiname = Verzeichnis
Schleife

Sichtbarkeit = swApp.DocumentVisible(Wahr, swDocPART)

Ende Sub
 

2

Ich habe ein weiteres Makro gefunden, das mir ein wenig mehr hilft. Aber ich stehe vor einem neuen Problem: Automatisierungsfehler: Das aufgerufene Objekt hat die Verbindung zu seinen Clients getrennt.

Beim Debuggen wird die Zeile Set Part = swApp.OpenDoc(File, swDocPART) angezeigt.  

Grundsätzlich listet das Makro auf, was ich brauche, indem ich die Teile nacheinander öffne und schließe, und dann exportiere ich die Liste.

Manchmal (oft) stürzt es jedoch im Unterricht ab... Wenn jemand sieht, woher dieser Fehler kommen kann...

3

Hallo

Hier ist ein Beispiel für Code, seien Sie vorsichtig, es wird nicht funktionieren, wenn eine andere Datei als ein sldprt in der Dateiliste gefunden wird, Sie müssen eine Überprüfung des Dateityps hinzufügen, bevor Sie ihn in SW öffnen:

'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

Herzliche Grüße