Hello in this code I want to make a save as in order to choose the location where to save the file. I tried several methods (Saveas Save as3 runcommand...) in vain.
Several methods work in debug mode but not so macro run from SW.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swExt As ModelDocExtension
Dim bRet As Boolean
Sub addSameLink()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' === Vérifie document ===
If swModel Is Nothing Then
MsgBox "Aucun document actif", vbExclamation
Exit Sub
End If
Set swExt = swModel.Extension
' === Chemin fichier ===
Dim swPath As String
swPath = swModel.GetPathName
' === Enregistrer si nécessaire ===
If swPath = "" Then
MsgBox "Fenêtre enregister sous à ouvrir ici pour chemin fichier (fichier sldprt et déjà nommé)"
swApp.RunCommand 620, ""
swPath = swModel.GetPathName
If swPath = "" Then
MsgBox "Enregistrement annulé.", vbExclamation
Exit Sub
End If
End If
' === Chemin PDF attendu ===
Dim pdfPath As String
pdfPath = Left(swPath, InStrRev(swPath, ".") - 1) & ".pdf"
Debug.Print "PDF attendu : " & pdfPath
' === Si PDF absent => sélection utilisateur ===
If Dir(pdfPath) = "" Then
Dim xlApp As Object
Dim fd As Object
Dim selectedFile As String
' ? Lancement Excel (solution fiable)
Set xlApp = CreateObject("Excel.Application")
Set fd = xlApp.FileDialog(3) ' FilePicker
With fd
.Title = "Sélectionner la fiche technique du MR (Fichier Pdf qui sera renommé et déplacé automatiquement)"
.Filters.Clear
.Filters.Add "Fichiers PDF", "*.pdf"
.AllowMultiSelect = False
' Option : ouverture dans le bon dossier
.InitialFileName = Left(swPath, InStrRev(swPath, "\"))
If .Show <> -1 Then
MsgBox "Aucun fichier sélectionné.", vbExclamation
xlApp.Quit
Set xlApp = Nothing
Exit Sub
End If
selectedFile = .SelectedItems(1)
End With
' Fermeture Excel
xlApp.Quit
Set xlApp = Nothing
' === Vérifications ===
If LCase(Right(selectedFile, 4)) <> ".pdf" Then
MsgBox "Le fichier sélectionné n'est pas un PDF.", vbCritical
Exit Sub
End If
' === Copie + renommage ===
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fso.MoveFile selectedFile, pdfPath
If Err.Number <> 0 Then
MsgBox "Erreur lors de la copie du PDF.", vbCritical
Exit Sub
End If
On Error GoTo 0
End If
' === Ajout Design Binder ===
Dim bRes As Boolean
bRes = swExt.InsertAttachment(pdfPath, True)
If bRes Then
Dim swCustProp As CustomPropertyManager
Set swCustProp = swExt.CustomPropertyManager("")
bRet = swCustProp.Add3("Material", _
swCustomInfoType_e.swCustomInfoText, _
"Pdf", _
swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
MsgBox "Fiche technique motoréducteur(pdf) ajouté au classeur de conception."
Else
MsgBox "Echec de l'insertion du PDF", vbExclamation
End If
End Sub
Hello,
For my part, after various crashes of SW2025 with the functions I was using to display a Windows Explorer window, I switched to calling the Excel function.
My code snippet:
Public Function GetFolder(Title As String)
Dim folder As FileDialog
Dim selected_folder As String
Set folder = Excel.Application.FileDialog(msoFileDialogFolderPicker)
With folder
.AllowMultiSelect = False
.ButtonName = "Ok"
.Filters.Clear
.InitialFileName = sInitialFolder 'Nom du dossier ouvert à l'affichage de la fenêtre
.Title = Title
If .Show <> -1 Then GoTo NextCode
selected_folder = .SelectedItems(1)
End With
NextCode:
Debug.Print selected_folder
GetFolder = selected_folder
Set folder = Nothing
End Function
For your information, I also invite you to anticipate Microsoft's abandonment of objects related to Microsoft Scripting Runtime (FSO) and to replace it with pure VB code.
1 Like
Hello,
I'm not an expert in macro but I managed to cobble together something that works for me.
Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swFile As ModelDoc2
Dim swCustomPropMgr As CustomPropertyManager
Dim docBE As Object
Dim chemin As String
Dim chemin2 As String
Dim sh As Object
Dim newname As String
Dim rawValue As String
Dim resolvedValue As String
Dim status As Long
Dim flags As Long
Dim saveas As Boolean
Set swApp = Application.SldWorks
Set swFile = swApp.ActiveDoc
'récup des propriétés personnalisées
Set swCustomPropMgr = swFile.Extension.CustomPropertyManager("")
'Récupération de valeur évaluée de la propriété PMI
status = swCustomPropMgr.Get4("PMI", False, rawValue, resolvedValue)
newname = resolvedValue
'Demander le dossier
Set sh = CreateObject("Shell.Application")
'Nouveau style + zone d'édition + validation
flags = &H40 Or &H10 Or &H20
'Désignation du dossier pas défaut
Set docBE = sh.Namespace("T:\BUREAU ETUDES\Données_SW")
'Fenêtre de dialogue pour choisir le dossier
chemin = sh.BrowseForFolder(0, "Sélectionnez le dossier de destination", flags, docBE).Self.Path
'Création du chemin complet + nom de fichier
chemin2 = chemin & "\" & newname & ".sldprt"
'Enregistrement
saveas = swFile.SaveAs2(chemin2, 0, True, True)
'Fermeture du modèle
Dim swModel As IModelDoc2
Dim docName As String
Set swModel = swApp.ActiveDoc
docName = swModel.GetTitle
swApp.CloseDoc docName
'Ouverture du document généré
Dim err As Long
Dim warn As Long
Set swModel = swApp.OpenDoc6(chemin2, swDocPART, swOpenDocOptions_Silent, "", err, warn)
End Sub
This macro retrieves a personal property that will be used for the name of the file, asks me where to save (with part of the path pre-populated), save, closes and opens the file in question.
Have a nice day 
(in Nantes 26°C at 7am...)
1 Like
Here's what I've also tinkered with in the meantime.
Excel function too as @Cyril_f not a fan of the solution but for lack of better...
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swExt As ModelDocExtension
Dim bRet As Boolean
Sub addSameLink()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' === Vérifie document ===
If swModel Is Nothing Then
MsgBox "Aucun document actif", vbExclamation
Exit Sub
End If
Set swExt = swModel.Extension
' === Chemin fichier ===
Dim swPath As String
swPath = swModel.GetPathName
' === Enregistrer si nécessaire ===
' === Enregistrement si nécessaire ===
If swPath = "" Then
Dim xlApp2 As Object
Dim fd2 As Object
Dim folderPath As String
Dim fileName As String
Dim fullPath As String
Dim errors As Long
Dim warnings As Long
' Lancement Excel
Set xlApp2 = CreateObject("Excel.Application")
Set fd2 = xlApp2.FileDialog(4) ' 4 = FolderPicker
With fd2
.Title = "Choisir le dossier d'enregistrement de la pièce"
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox "Aucun dossier sélectionné.", vbExclamation
xlApp2.Quit
Set xlApp2 = Nothing
Exit Sub
End If
folderPath = .SelectedItems(1)
End With
' Fermeture Excel
xlApp2.Quit
Set xlApp2 = Nothing
' Nom basé sur la pièce
fileName = swModel.GetTitle
If InStrRev(fileName, ".") > 0 Then
fileName = Left(fileName, InStrRev(fileName, ".") - 1)
End If
' Chemin final
fullPath = folderPath & "\" & fileName & ".sldprt"
' Sauvegarde
Debug.Print fullPath
Dim saveOk As Boolean
saveOk = swModel.Extension.SaveAs3(fullPath, 0, 0, Nothing, Nothing, errors, warnings)
If saveOk = False Then
MsgBox "Erreur lors de l'enregistrement.", vbCritical
Exit Sub
End If
swPath = swModel.GetPathName
End If
' === Chemin PDF attendu ===
Dim pdfPath As String
pdfPath = Left(swPath, InStrRev(swPath, ".") - 1) & ".pdf"
Debug.Print "PDF attendu : " & pdfPath
' === Si PDF absent => sélection utilisateur ===
If Dir(pdfPath) = "" Then
Dim xlApp As Object
Dim fd As Object
Dim selectedFile As String
' ? Lancement Excel (solution fiable)
Set xlApp = CreateObject("Excel.Application")
Set fd = xlApp.FileDialog(3) ' FilePicker
With fd
.Title = "Sélectionner la fiche technique du MR (Fichier Pdf qui sera renommé et déplacé automatiquement)"
.Filters.Clear
.Filters.Add "Fichiers PDF", "*.pdf"
.AllowMultiSelect = False
' Option : ouverture dans le bon dossier
.InitialFileName = Left(swPath, InStrRev(swPath, "\"))
If .Show <> -1 Then
MsgBox "Aucun fichier sélectionné.", vbExclamation
xlApp.Quit
Set xlApp = Nothing
Exit Sub
End If
selectedFile = .SelectedItems(1)
End With
' Fermeture Excel
xlApp.Quit
Set xlApp = Nothing
' === Vérifications ===
If LCase(Right(selectedFile, 4)) <> ".pdf" Then
MsgBox "Le fichier sélectionné n'est pas un PDF.", vbCritical
Exit Sub
End If
' === Copie + renommage ===
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fso.MoveFile selectedFile, pdfPath
If Err.Number <> 0 Then
MsgBox "Erreur lors de la copie du PDF.", vbCritical
Exit Sub
End If
On Error GoTo 0
End If
' === Ajout Design Binder ===
Dim bRes As Boolean
bRes = swExt.InsertAttachment(pdfPath, True)
If bRes Then
Dim swCustProp As CustomPropertyManager
Set swCustProp = swExt.CustomPropertyManager("")
bRet = swCustProp.Add3("Material", _
swCustomInfoType_e.swCustomInfoText, _
"Pdf", _
swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
MsgBox "Fiche technique motoréducteur(pdf) ajouté au classeur de conception."
Else
MsgBox "Echec de l'insertion du PDF", vbExclamation
End If
' === Sauvegarde finale ===
Dim errorsSave As Long
Dim warningsSave As Long
Dim saveFinalOk As Boolean
saveFinalOk = swModel.Save3(0, errorsSave, warningsSave)
If saveFinalOk = False Or errorsSave <> 0 Then
MsgBox "Erreur lors de la sauvegarde finale. Code : " & errorsSave, vbCritical
Else
Debug.Print "Fichier sauvegardé avec succès."
End If
End Sub
I am still looking at your solutions, but the urgency was to make it functional, which is being done.
Now I'll be able to make changes quietly.
It seems to me that the SW explorer window is only displayed to manage SW-type extensions, so for pdf unfortunately you have to go through other functions.
1 Like
Hello;
I have the same feeling as @Cyril_f , by renunciation, I go through Excel functions.
But if you want to open your chakras to other solutions, the
" BrowseForFileSave " works fine (until Solidworks 2022 anyway).
exhibited here: Macro to export selected bodies to foreign format
1 Like
@Cyril_f
It's still a shame, but not successful either so far the 1st solution worked in the command window but not from Sw...
I'm going to look at your function, whether or not different from what I do.
@Maclane
I'm looking at your solution, if it can work for me, I'll be a taker.
@a_eriaud
I just looked at your solution, I had done the same thing but I hate this window (Browse for folder) you can't find the favorites and like on networks to save with multiple folders, it's long and annoying to get the right path. On the other hand, it's functional but impractical.
And here in Quimperlé 30° in the office when I arrived at 6 a.m. this morning. After opening the windows it went back down to 28°.
Fortunately, the time shifted to 2:45 p.m., the day is over, but it's going to be complicated today. 
(Air conditioning in installation, can't wait for it to be finished...)
Admittedly, the navigation is not fluid in the folders with this window.
But since I always have a Windows file explorer open on my working folder, I do a vulgar copy/paste of the explorer's path into the " folder " box of the window.
1 Like
Hello,
For me this code (proposed by @Maclane) crashes SW from Windows 11 25H2 (a bit randomly but quite wobbly hence the fact of going through Excel)
I tried to make it work ( @Maclane code) and it failed. In addition, if not functional on version W11 25H2, I will keep the functionality via Excel.
The advantage of the solution via Excel (besides its stability) is that it makes it easy to set a pre-selected location for opening the Windows Explorer window. (InitialFileName) which is very convenient.
See you noonnnn!! I'll have to modify a good part of my macros 
(Sniff!) 
... a chance finally that @sbadenis wiped the plasters before me... 
1 Like
The problem is that we use codes that are starting to date (for my part, I must have been using a similar code for more than 6 years).
It's like for FileSystemObject, abandonment coming from Microsoft, for now it's just logged in to the Windows event viewer.
1 Like
… more than 13 years for my oldest ...
Argh !! Already I only update the Solidworks API functions when they don't work anymore (obsolescence or abandonment) and if I have to deal with Windows / and Excel it becomes complicated.
1 Like
On the other hand, the Excel solution showed me this:
I already had another excel window open which may explain the problem.
The problem appeared after opening the excel window for choosing the folder after 5-10s max. I chose my folder, clicked on retry and here I go again.
It did this to me on 3-4 tries and after closing Excel file + solidworks no more worries
1 Like