Bonjour dans ce code je souhaite faire un enregistrer sous afin de choisir l’emplacement ou enregistrer le fichier. J’ai essayé plusieurs méthode (Saveas Save as3 runcommand…) en vain.
Plusieurs méthode fonctionne en mode debug mais pas si macro lancer depuis 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
Pour ma part, après diverses plantages de SW2025 avec les fonctions que j’utilisais pour afficher une fenêtre d’explorateur Windows, j’ai basculé sur l’appel de la fonction Excel.
Mon bout de code:
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
Pour information, je t’invite également à anticiper l’abandon par Microsoft des objets liés à Microsoft Scripting Runtime (FSO) et de remplacer ça par du code pur VB.
Hello,
Je ne suis pas expert en macro mais j’ai réussi à bricoler un truc qui fonctionne pour moi.
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
Cette macro récupère une propriété perso qui servira pour le nom du fichier, me demande où enregistrer (avec une partie du chemin pré-renseigné), enregistrer, ferme et ouvre le fichier en question.
Voici ce que j’ai bricolé aussi entre temps.
fonction excel aussi comme @Cyril_f pas fan de la solution mais à défaut de mieux…
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
Je regarde quand même vos solutions, mais l’urgence était de la rendre fonctionnel, ce qui est fait.
Maintenant je vais pourvoir apporter des modifications tranquillement.
Il me semble que la fenêtre d’explorateur de SW ne s’affiche que pour gérer les extensions de type SW donc pour du pdf malheureusement faut passer par d’autres fonctions.
J’ai le même ressenti que @Cyril_f , par renoncement, je passe par les fonctions Excel.
Mais si tu souhaite ouvrir tes chakras à d’autres solutions, la fonction
« BrowseForFileSave » fonctionne correctement (jusqu’à Solidworks 2022 en tout cas).
exposée ici: Macro to export selected bodies to foreign format
@Cyril_f
C’est quand même franchement dommage, mais pas réussi non plus jusqu’à là la 1ère solution fonctionnait dans la fenêtre de commande mais pas depuis Sw…
Je vais regarder ta fonction, si différente ou pas de ce que je fais.
@Maclane
Je regarde ta solution si cela peut fonctionné pour moi je serais prenneur.
@a_eriaud
Je viens de regarder ta solution, j’avais fait la même chose mais je déteste cette fenêtre (Browse for folder) on y retrouve pas les favoris et comme sur réseaux pour enregistrer avec des dossiers multiple, c’est long et chiant pour obtenir le bon chemin. En revanche c’est fonctionnel mais peu pratique.
Et ici à Quimperlé 30° dans le bureau à mon arrivé à 6h, ce matin. Après ouverture des fenêtre c’est redescendu à 28°.
Heureusement horaire décalé à 14h45 journée terminée mais ça va être compliqué aujourd’hui. (Clim en installation vivement que ce soit terminé…)
Certes la navigation n’est pas fluide dans les dossiers avec cette fenêtre.
Mais comme j’ai toujours un explorateur de fichier Windows ouvert sur mon dossier de travaille, je fais un vulgaire copier/coller du chemin de l’explorateur dans la case « dossier » de la fenêtre.
J’ai essayé de le faire fonctionné (code de @Maclane ) et c’est un échec. De plus si non fonctionnel sur version W11 25H2 je vais conservé la fonctionnalité via Excel.
L’avantage de la solution via Excel (outre sa stabilité) est qu’il permet de définir facilement un emplacement présélectionné pour l’ouverture de la fenêtre de l’explorateur Windows. (InitialFileName) ce qui est bien pratique.
A Nooonnnn !! Il vas falloir que je modifie une bonne partie de mes macros (Snif ! ) … une chance finalement que @sbadenis essuyâtes les plâtres avant moi…
Le problème c’est que l’on utilise des codes qui commencent à dater (pour ma part ça devait faire plus de 6 ans que j’utilisais un code semblable).
C’est comme pour FileSystemObject, abandon à venir de la part de Microsoft, pour l’instant c’est juste logué dans l’observateur d’évènement de Windows.
Argh !!! Deja que je ne met à jour les fonctions API Solidworks uniquement quand elles ne fonctionnent plus (obsolescence ou abandons) et s’il faut en plus composer avec Windows / et Excel cela devient compliqué.
J’avais déjà une autre fenêtre excel d’ouverte qui explique peut-être le soucis.
Le problème est apparu après l’ouverture de la fenêtre excel pour choix du dossier au bout de 5-10s max. J’ai choisi mon dossier cliqué sur retry et c’est reparti.
cela m’a fait ça sur 3-4 essai et après fermeture fichier excel + solidworks plus de soucis
Bonjour,
Je reviens sur ce sujet un peu tard mais il n’est jamais trop tard pour bien faire ^^.
Le problème est que le VBA offre moins d’options que le C# avec .Net
En C# c’est très simple :
if (saveFileDialog1.ShowDialog() == DialogResult.OK)
{
swDoc.SaveAs(saveFileDialog1.FileName);
}
Mais si vous voulez rester en VBA voici un petit bout de code qui devrait correspondre à vos besoins
Dim swApp As Object
Sub main()
Dim filePath As String
filePath = ShowNetSaveFileDialog()
If filePath <> "" Then
' Sauvegarde SolidWorks ici
MsgBox "Fichier choisi : " & filePath
End If
Set swApp = Application.SldWorks
End Sub
Function ShowNetSaveFileDialog() As String
Dim psScript As String
' Script PowerShell avec du code C# incorporé
psScript = "Add-Type -AssemblyName System.Windows.Forms; " & _
"$dialog = New-Object System.Windows.Forms.SaveFileDialog; " & _
"$dialog.Filter = 'Fichiers SolidWorks (*.sldprt)|*.sldprt'; " & _
"if ($dialog.ShowDialog() -eq [System.Windows.Forms.DialogResult]::OK) { $dialog.FileName }"
' Exécution via WScript.Shell
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
Dim exec As Object
Set exec = wsh.exec("powershell -Command """ & psScript & """")
ShowNetSaveFileDialog = Trim(exec.StdOut.ReadAll())
End Function
Je viens de tester le code et j’ai 2 comportements étonnants.
Le 1er la fenêtre PowerShell qui s’ouvre entre SW et la fenêtre de l’explorateur SW.
Je l’ai résolue en remplaçant:
Set exec = wsh.exec("powershell -Command """ & psScript & """")
Ce qui est plus agréable mais ne change pas le fonctionnement.
PAr contre si je créer une pièce (nom pièce1 par défaut lors de la création) et je lance la macro et enregistre sous D:\Test.sldprt) à la fin de la macro la pièce 1 est toujours présente et dans le D je trouve une copie de la pièce 1.
Donc pour moi la macro fais un enregistrer copie sous ou lieu de enregistrer sous.
Une idée du pourquoi?.
Sinon utiliser PowerShell me semble aussi une bonne idée (Actuellement je suis toujours avec la méthode Excel)
Je l’ai testé tel quel (copier-coller de ton code) et très légèrement modifié et le comportement est le même dans les 2 cas il me fait une copie sous et conserve la pèce d’origine ouverte et non sauvegardé.
Pour le test pièce nouvelle (nommée pour moi Pièce1)
Lancer la macro et enregistrer sous D:\Test.sldprt.
La macro renvoi bien le nom de la nouvelle pièce dans le Msgbox. Mais la pièce1 reste la pièce ouverte et non sauvegardé. (comme lors d’un enregistré copie sous.
Dim swApp As Object
Sub main()
Dim filePath As String
filePath = ShowNetSaveFileDialog()
If filePath <> "" Then
' Sauvegarde SolidWorks ici
MsgBox "Fichier choisi : " & filePath
End If
Set swApp = Application.SldWorks
End Sub
Function ShowNetSaveFileDialog() As String
Dim psScript As String
' Script PowerShell avec du code C# incorporé
psScript = "Add-Type -AssemblyName System.Windows.Forms; " & _
"$dialog = New-Object System.Windows.Forms.SaveFileDialog; " & _
"$dialog.Filter = 'Fichiers SolidWorks (*.sldprt)|*.sldprt'; " & _
"if ($dialog.ShowDialog() -eq [System.Windows.Forms.DialogResult]::OK) { $dialog.FileName }"
' Exécution via WScript.Shell
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
Dim exec As Object
'Set exec = wsh.exec("powershell -Command """ & psScript & """")
Set exec = wsh.exec("powershell.exe -NoProfile -NonInteractive -WindowStyle Hidden -Command """ & psScript & """")
ShowNetSaveFileDialog = Trim(exec.StdOut.ReadAll())
End Function
(Snif ! 
) … une chance finalement que 
