Je voudrais exécuter une macro permettant d'ouvrir toutes les mises en plan d'un dossier et des sous dossiers.
Pour le moment, je sélectionne un dossier mais elle ne m'ouvre que les mises en plan contenu dans le dossier et pas dans les sous dossier.
Quelle est la méthode pour récupérer les sous dossiers d'un répertoire afin d'ouvrir les fichiers contenus ?
Voici mon bout de code me permettant d'ouvrir les mises en plan d'un dossier :
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
Salut, Tu dois lister les sous dossiers et répéter ton opération.
Regarde cet exemple avec FSO : https://www.developpez.net/forums/d976685/logiciels/microsoft-office/excel/macros-vba-excel/lister-dossiers-sous-dossiers/#post5476972
J'ai réussi à avancer dans ma macro. Cependant sur des gros dossiers avec plus de 150 mises en plans, il me dit que mes ressources de fenêtrage sont insuffisante alors que j'ouvre chaque mise en plan j'enregistre celle ci en PDF et DXF selon plusieurs formats de mise en plan et je la referme aussitôt.
Peut être qu'il me manque un "unlord" quelque part...
Pour info voici ma macro permettant d'ouvrir les mises en plan dans le répertoire cible et les mises en plan dans les sous-dossiers :
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!")
A mon avis en première approche, je pense que c'est les Set swApp = Application.SldWorks qui posent problème. A partir du moment où tu as ouvert une session de Solidworks il faut juste la maintenir ouverte et la remettre au premier plan sans refaire appel à elle par un nouveau Set swApp.
En l'état tu dois avoir de multiple process SW d'ouverts et c'est ce qui fait planter sur un gros dossier.