Ik wil graag een macro uitvoeren om alle tekeningen van een map en submappen te openen.
Op dit moment selecteer ik een map, maar deze opent alleen de tekeningen in de map en niet in de submappen.
Wat is de methode voor het ophalen van submappen van een map om de ingesloten bestanden te openen?
Hier is mijn stukje code waarmee ik de tekeningen van een map kan openen:
CurrentPath = CurrentPath & "\"
sfilename = Dir(CurrentPath & "*.slddrw")
'Ouverture des mises en plan dans le dossier
Do Until sfilename = ""
'Ouverture
Set swApp = Application.SldWorks
Set swModel = swApp.OpenDoc6(CurrentPath & sfilename, 3, 0, "", longstatus, longwarnings)
swApp.ActivateDoc2 sfilename, False, longstatus
Set swModel = swApp.ActiveDoc
sfilename = dir
Loop
Hoi, U moet een lijst van de submappen en herhaal uw bewerking.
Kijk naar dit voorbeeld met FSO: https://www.developpez.net/forums/d976685/logiciels/microsoft-office/excel/macros-vba-excel/lister-dossiers-sous-dossiers/#post5476972
Het lukte me om vooruit te komen in mijn macro. Bij grote bestanden met meer dan 150 tekeningen vertelt het me echter dat mijn vensterbronnen onvoldoende zijn terwijl ik elke tekening open, ik sla deze op in PDF en DXF volgens verschillende tekenformaten en ik sluit deze onmiddellijk.
Ter info, hier is mijn macro om de tekeningen in de doelmap en de tekeningen in de submappen te openen:
Set swApp = Application.SldWorks
'Sélection du dossier
CurrentPath = SelectFolder("Select Folder", "")
If CurrentPath = "" Then
Exit Sub
End If
CurrentPath = CurrentPath & "\"
sfilename = Dir(CurrentPath & "*.slddrw")
'Ouverture des mises en plan dans le dossier
Do Until sfilename = ""
'Ouverture
Set swApp = Application.SldWorks
Set swModel = swApp.OpenDoc6(CurrentPath & sfilename, 3, 0, "", longstatus, longwarnings)
swApp.ActivateDoc2 sfilename, False, longstatus
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox ("Ouvrer une mise plan")
Else
Set swDraw = swModel
Set swSheet = swDraw.GetCurrentSheet
Set swModelDocExt = swModel.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
Set swLayerMgr = swModel.GetLayerManager
Set swLayer = swLayerMgr.GetLayer("CLIENT")
vLayerArr = swLayerMgr.GetLayerList
Presence_Client = False
For Each vLayer In vLayerArr
If vLayer = "CLIENT" Then
Presence_Client = True
End If
Next
'Opération sur nom du fichier
nom_Fichier = Strings.Left(swModel.GetPathName, Strings.Len(swModel.GetPathName) - 7)
nom_Ouvrir = swModel.GetPathName
Extension = Strings.Right(swModel.GetPathName, 7)
'Cache le calque CLIENT
If Presence_Client = True Then
If swLayer.Visible = True Then
swLayer.Visible = False
End If
End If
swExportPDFData.SetSheets swExportData_ExportCurrentSheet, ""
swExportPDFData.ViewPdfAfterSaving = False
'Active la première feuille
vSheetName = swDraw.GetSheetNames
bRet = swDraw.ActivateSheet(vSheetName(0))
'Enregistrement en PDF DXF PDF
bRet = swModel.Extension.SaveAs(nom_Fichier & " EXT.PDF", 0, 0, swExportPDFData, nErrors, nWarnings)
longstatus = swModel.SaveAs(nom_Fichier & " EXT.DXF")
DoEvents
If Presence_Client = True Then
swLayer.Visible = True
End If
longstatus = swModel.SaveAs(nom_Fichier & ".PDF")
'Fermeture du document
swApp.QuitDoc (nom_Ouvrir)
DoEvents
End If
sfilename = Dir
Loop
CurrentPath = Left(CurrentPath, Len(CurrentPath) - 1)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(CurrentPath)
CurrentPath = CurrentPath & "\"
'Ouverture des mises en plan dans les sous-dossiers
For Each SubFolder In SourceFolder.SubFolders
ssDossier = SubFolder.Path & "\"
sfileNamessdossier = Dir(ssDossier & "*.slddrw")
Do Until sfileNamessdossier = ""
'Ouverture
Set swApp = Application.SldWorks
Set swModel = swApp.OpenDoc6(ssDossier & sfileNamessdossier, 3, 0, "", longstatus, longwarnings)
swApp.ActivateDoc2 sfileNamessdossier, False, longstatus
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox ("Ouvrer une mise plan")
Else
Set swDraw = swModel
Set swSheet = swDraw.GetCurrentSheet
Set swModelDocExt = swModel.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
Set swLayerMgr = swModel.GetLayerManager
Set swLayer = swLayerMgr.GetLayer("CLIENT")
vLayerArr = swLayerMgr.GetLayerList
Presence_Client = False
For Each vLayer In vLayerArr
If vLayer = "CLIENT" Then
Presence_Client = True
End If
Next
'Opération sur nom du fichier
nom_Fichier = Strings.Left(swModel.GetPathName, Strings.Len(swModel.GetPathName) - 7)
nom_Ouvrir = swModel.GetPathName
Extension = Strings.Right(swModel.GetPathName, 7)
'Cache le calque CLIENT
If Presence_Client = True Then
If swLayer.Visible = True Then
swLayer.Visible = False
End If
End If
swExportPDFData.SetSheets swExportData_ExportCurrentSheet, ""
swExportPDFData.ViewPdfAfterSaving = False
'Active la première feuille
vSheetName = swDraw.GetSheetNames
bRet = swDraw.ActivateSheet(vSheetName(0))
'Enregistrement en PDF DXF PDF
bRet = swModel.Extension.SaveAs(nom_Fichier & " EXT.PDF", 0, 0, swExportPDFData, nErrors, nWarnings)
longstatus = swModel.SaveAs(nom_Fichier & " EXT.DXF")
DoEvents
If Presence_Client = True Then
swLayer.Visible = True
End If
longstatus = swModel.SaveAs(nom_Fichier & ".PDF")
'Fermeture du document
swApp.QuitDoc (nom_Ouvrir)
DoEvents
End If
sfileNamessdossier = Dir
Loop
'Unload sfileNamessdossier
Next SubFolder
MsgBox ("FINI!")
Naar mijn mening op het eerste gezicht denk ik dat het de Set swApp = Application.SldWorks is die het probleem is. Vanaf het moment dat je een Solidworks-sessie hebt geopend, hoef je deze alleen nog maar open te houden en weer op de voorgrond te zetten zonder hem opnieuw te gebruiken met een nieuwe swApp-set .
Zoals het er nu uitziet, moet je meerdere SW-processen open hebben staan en dat is wat er crasht op een groot bestand.