SW-API; Submap macro: bestandseigenschappen ophalen uit ss-mappen

Macro
1

Hallo

Ik heb verschillende berichten op verschillende forums gevonden, maar ik kan het niet doen...

De volgende macro, afgeleid van verschillende stukjes code, exporteert de beschrijvings-, nummer- en referentie-eigenschappen van SLDPRT-bestanden naar een Excel.

De macro gaat echter niet in de submappen en het lijkt erop dat ik daar niet heen kan!

Zou iemand zo vriendelijk willen zijn om me te helpen de code in te vullen?

Bij voorbaat dank,

 

 

Dim deel als SldWorks.ModelDoc2
Dim een als object
Dim fs als object
Dim CurrentPath als String
Submap dimmen als object


Functie SelectFolder(optionele titel als string, optionele TopFolder als string) als string

Dim objShell als nieuwe Shell32.Shell
Dim objFolder Als Shell32.Folder

'Als je op de volgende regel 16384 gebruikt in plaats van 1, worden er ook bestanden weergegeven

Stel objFolder in = objShell.BrowseForFolder(0, Titel, 1, TopFolder)
Zo niet, dan is objFolder niets

SelectFolder = objFolder.Items.Item.Path

Einde als

Functie beëindigen

Sub hoofd()

Stel swApp = Toepassing.SldWorks in

Set fs = CreateObject("Scripting.FileSystemObject")
bestandsnaam = InputBox("bestandsnaam: ")
filename = bestandsnaam & ".csv"
Stel a = fs. in. CreateTextFile("C:\Users\***********\Desktop\" & bestandsnaam, True)

Zichtbaarheid = swApp.DocumentVisible(False, swDocPART)
a.writeline ("Getal" & ";" & "Beschrijving" & ";" & "Verwijzing")

'Keuzemap + .sldprt-bestandsherstel

Currentpath = SelectFolder("Map selecteren", "")

Als currentpath = "" dan
Einde als
Currentpath = Huidig pad & "\"

Bestandsnaam = Dir(Huidig pad & "*.sldprt")
Einde fase


Doen terwijl Bestandsnaam <> ""
Set Part = swApp.OpenDoc(Currentpath & FileName, swDocPART)
Description = Part.GetCustomInfoValue("", "Beschrijving")
Getal = Deel.GetCustomInfoValue("", "Getal")
Referentie = Part.GetCustomInfoValue("", "referentie")
a.writeline (Getal&";" & Beschrijving &";" & Verwijzing)
swApp.CloseDoc Bestandsnaam
Bestandsnaam = Dir
Strik

Zichtbaarheid = swApp.DocumentVisible(True, swDocPART)

Einde Sub
 

2

Ik heb een andere macro gevonden die me een beetje meer helpt. Maar ik word geconfronteerd met een nieuw probleem: Automatiseringsfout: het aangeroepen object heeft de verbinding met zijn clients verbroken.

debugging toont de regel:  Set Part = swApp.OpenDoc(File, swDocPART)

Kortom, de macro geeft een lijst van wat ik nodig heb door de stukken één voor één te openen en te sluiten, en vervolgens exporteer ik de lijst.

Soms (vaak) crasht het echter in de klas... Als iemand ziet waar deze fout vandaan kan komen...

3

Hallo

Hier is een voorbeeld van code, wees voorzichtig dat het niet werkt als een ander bestand dan een sldprt wordt gevonden in de bestandslijst, u moet een controle op het bestandstype toevoegen voordat u het in SW opent:

'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

Vriendelijke groeten