Witam
Chcę uruchomić makro, aby otworzyć wszystkie rysunki folderu i podfolderów.
Na razie wybieram folder, ale otwiera on tylko rysunki zawarte w folderze, a nie w podfolderach.
Jaka jest metoda pobierania podfolderów katalogu w celu otwarcia zawartych w nich plików?
Oto mój fragment kodu, który pozwala mi otworzyć rysunki folderu:
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
Z góry dziękujemy,
Gautier
Cześć, Musisz wyświetlić listę podfolderów i powtórzyć operację.
Spójrz na ten przykład z FSO: https://www.developpez.net/forums/d976685/logiciels/microsoft-office/excel/macros-vba-excel/lister-dossiers-sous-dossiers/#post5476972
2 polubienia
Witam
Oprócz remrem, użyłem wczoraj kodu z tej strony , działa bardzo dobrze
1 polubienie
Dziękuję za odpowiedzi. Jakie referencje należy dodać, aby to zadziałało?
Środowisko uruchomieniowe skryptów firmy Microsoft
1 polubienie
Witam
Udało mi się przesunąć do przodu w moim makro. Jednak w przypadku dużych plików zawierających więcej niż 150 rysunków informuje mnie, że moje zasoby okien są niewystarczające, gdy otwieram każdy rysunek, zapisuję go w formacie PDF i DXF zgodnie z kilkoma formatami rysunków i natychmiast go zamykam.
Może gdzieś brakuje mi jakiegoś "unlorda"...
Jakieś pomysły?
Z góry dziękujemy,
Gautier.
FYI, oto moje makro do otwierania rysunków w katalogu docelowym i rysunków w podfolderach:
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!")
1 polubienie
Witam
Moim zdaniem na pierwszy rzut oka myślę, że to Set swApp = Application.SldWorks jest problemem. Od momentu otwarcia sesji Solidworks, wystarczy pozostawić ją otwartą i umieścić z powrotem na pierwszym planie bez ponownego użycia z nowym zestawem swApp .
W obecnej sytuacji musisz mieć otwartych wiele procesów oprogramowania i to właśnie powoduje awarię dużego pliku.
Więc umieściłem "Set swApp = Application.SldWorks" tuż przed moją pierwszą pętlą DO i usunąłem pozostałe?
Ponownie
Tak, zgadza się. A kiedy już to zrobisz, na końcu kodu po całym przetwarzaniu, dodaj:
Set swModel = Nothing
Set swApp= Nothing
Spowoduje to rozładowanie pamięci.
To było słuszne. Umieściłem więc funkcję:
Ustaw swModel = Nic
Ustaw swApp= Nic
Na samym końcu mojego makro.
Usuń swApp = Application.SldWorks Set w moich pętlach
I dodaj swModel = Nic ustawione na końcu każdej z moich pętli.
Dziękuję za pomoc.
Miłego dnia
Gautier.