I would like to run a macro to open all the drawings of a folder and subfolders.
For the moment, I select a folder but it only opens the drawings contained in the folder and not in the subfolders.
What is the method for retrieving subfolders of a directory in order to open the contained files?
Here is my snippet of code allowing me to open the drawings of a folder:
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
Hi, You need to list the subfolders and repeat your operation.
Look at this example with FSO: https://www.developpez.net/forums/d976685/logiciels/microsoft-office/excel/macros-vba-excel/lister-dossiers-sous-dossiers/#post5476972
I managed to move forward in my macro. However, on large files with more than 150 drawings, it tells me that my windowing resources are insufficient while I open each drawing, I save it in PDF and DXF according to several drawing formats and I close it immediately.
FYI, here is my macro to open the drawings in the target directory and the drawings in the subfolders:
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!")
In my opinion at first glance, I think it's the Set swApp = Application.SldWorks that are the problem. From the moment you have opened a Solidworks session, you just have to keep it open and put it back in the foreground without using it again with a new swApp set .
As it stands, you must have multiple SW processes open and that's what crashes on a big file.