Interfejs API oprogramowania; Makro podfolderu: pobieranie właściwości pliku z folderów ss

Macro
1

Witam

Znalazłem kilka postów na różnych forach, ale nie mogę tego zrobić...

Poniższe makro, pochodzące z kilku fragmentów kodu, eksportuje właściwości Description, Number i Reference plików SLDPRT do programu Excel.

Jednak makro nie trafia do podfolderów i nie mogę tam wejść!

Czy ktoś byłby na tyle uprzejmy, aby pomóc mi ukończyć kod?

Z góry dzięki,

 

 

Przyciemnij część jako SldWorks.ModelDoc2
Przyciemnij obiekt jako
Dim fs Jako obiekt
Przyciemnij bieżącą ścieżkę jako ciąg
Przyciemnij podfolder jako obiekt


Funkcja SelectFolder(opcjonalny tytuł jako ciąg, opcjonalny topFolder jako ciąg) jako ciąg

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

'Jeśli użyjesz 16384 zamiast 1 w następnym wierszu, pliki są również wyświetlane

Ustaw objFolder = objShell.BrowseForFolder(0, Tytuł, 1, FolderGłówny)
jezeli nie objfolder to nic to nic to

SelectFolder = objFolder.Items.Item.Path

Zakończ jeżeli:

Zakończ funkcję

Sub main()

Ustaw swApp = Application.SldWorks

Ustaw fs = CreateObject("Scripting.FileSystemObject")
filename = InputBox("nazwa_pliku: ")
filename = nazwa pliku & ".csv"
Ustaw a = fs. CreateTextFile("C:\Users\***********\Desktop\" & nazwa pliku, Prawda)

Widoczność = swApp.DocumentVisible(False, swDocPART)
a.writeline ("Numer" & ";" & "Opis" & ";" & "Odniesienie")

'Wybór folderu + odzyskiwanie pliku .sldprt

Currentpath = SelectFolder("Wybierz folder", "")

Jeśli bieżąca ścieżka = "" to
Zakończ jeżeli:
Currentpath = Bieżąca ścieżka & "\"

FileName = Dir(Bieżąca ścieżka & "*.sldprt")
Koniec fazy


Wykonaj while FileName <> ""
Ustaw część = swApp.OpenDoc(Bieżąca ścieżka i nazwa_pliku, swDocPART)
Opis = Part.GetCustomInfoValue("", "Opis")
Numer = Part.GetCustomInfoValue("", "Liczba")
Odniesienie = Part.GetCustomInfoValue("", "odniesienie")
a.writeline (Numer&";" & Opis &";" & Odniesienie)
swApp.CloseDoc Nazwa pliku
nazwa_pliku = katalog
Pętla

Widoczność = swApp.DocumentVisible(True, swDocPART)

Koniec subwoofera
 

2

Znalazłem inne makro, które pomaga mi trochę bardziej. Ale mam do czynienia z nowym problemem: Błąd automatyzacji: wywoływany obiekt rozłączył się ze swoimi klientami.

debugging pokazuje wiersz:  Set Part = swApp.OpenDoc(File, swDocPART)

Zasadniczo makro wyświetla to, czego potrzebuję, otwierając i zamykając elementy jeden po drugim, a następnie eksportuję listę.

Czasami jednak (często) zawiesza się w klasie... Jeśli ktoś widzi, skąd może pochodzić ten błąd...

3

Witam

Oto przykład kodu, należy uważać, że nie zadziała, jeśli na liście plików zostanie znaleziony plik inny niż sldprt, musisz dodać kontrolę typu pliku przed otwarciem go w 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

Pozdrowienia