In SolidWorks, is it possible to ‘Save As’ using a window that opens?
At the moment, I’m using a workaround via Excel.
The aim is to save a file to a location of the user’s choice, and then to be able to select the file in a second window.
Exemple with Excel:
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