Hallo, in diesem Code möchte ich speichern, um den Speicherort für die Datei auszuwählen. Ich habe mehrere Methoden ausprobiert (Saveas Save as3 Runcommand...), aber vergeblich.
Mehrere Methoden funktionieren im Debug-Modus, laufen aber nicht so makromäßig von SW aus.
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
Hallo,
Meinerseits habe ich nach verschiedenen Abstürzen von SW2025 mit den Funktionen, die ich zur Anzeige eines Windows-Explorer-Fensters verwendet habe, auf die Excel-Funktion umgestellt.
Mein Code-Schnipsel:
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
Zu Ihrer Information lade ich Sie außerdem ein, Microsofts Aufgabe von Objekten im Zusammenhang mit Microsoft Scripting Runtime (FSO) vorauszusehen und durch reinen VB-Code zu ersetzen.
1 „Gefällt mir“
Hallo,
Ich bin kein Experte für Makro, aber ich habe es geschafft, etwas zusammenzustellen, das für mich funktioniert.
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
Dieses Makro ruft eine persönliche Eigenschaft ab, die für den Namen der Datei verwendet wird, fragt mich, wo ich speichern soll (mit einem Teil des Pfades vorab ausgefüllt), speichert, schließt und öffnet die betreffende Datei.
Schönen Tag 
(in Nantes 26°C um 7 Uhr morgens...)
1 „Gefällt mir“
Hier ist, woran ich in der Zwischenzeit auch herumgebastelt habe.
Excel funktioniert auch, da @Cyril_f kein Fan der Lösung, aber mangels besserer Lösung...
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
Ich schaue mir deine Lösungen noch an, aber die Dringlichkeit war, es funktionsfähig zu machen, was gerade getan wird.
Jetzt kann ich leise Änderungen vornehmen.
Mir scheint, dass das SW-Explorer-Fenster nur zur Verwaltung von SW-ähnlichen Erweiterungen angezeigt wird, daher muss man für PDFs leider andere Funktionen durchlaufen.
1 „Gefällt mir“
Hallo;
Ich habe dasselbe Gefühl wie @Cyril_f : Durch Verzicht gehe ich durch Excel-Funktionen.
Aber wenn du deine Chakren für andere Lösungen öffnen willst, dann
" BrowseForFileSave" funktioniert einwandfrei (zumindest bis Solidworks 2022).
hier ausgestellt: Makro zum Export ausgewählter Körper in fremdes Format
1 „Gefällt mir“
@Cyril_f
Es ist immer noch schade, aber bisher auch nicht erfolgreich – die erste Lösung funktionierte im Befehlsfenster, aber nicht von Sw aus...
Ich schaue mir deine Funktion an, ob sie sich von meiner Arbeit unterscheidet oder nicht.
@Maclane
Ich schaue mir deine Lösung an, wenn sie für mich funktionieren kann, nehme ich es.
@a_eriaud
Ich habe mir gerade deine Lösung angesehen, ich habe das Gleiche gemacht, aber ich hasse dieses Fenster (Ordner durchsuchen), man findet die Favoriten und Likes in Netzwerken nicht, um mit mehreren Ordnern zu speichern, es ist lang und nervig, den richtigen Pfad zu finden. Andererseits ist es funktional, aber unpraktisch.
Und hier in Quimperlé 30° im Büro, als ich heute Morgen um 6 Uhr ankam. Nachdem ich die Fenster geöffnet hatte, sank es wieder auf 28°.
Glücklicherweise wurde die Zeit auf 14:45 Uhr verschoben, der Tag ist vorbei, aber heute wird es kompliziert. (Klimaanlage in Installation, kann es kaum erwarten, bis sie fertig ist...)
Zugegeben, die Navigation in den Ordnern mit diesem Fenster ist nicht flüssig.
Da ich aber immer einen Windows-Dateiexplorer in meinem Arbeitsordner offen habe, kopiere ich den Pfad des Explorers vulgär in das "Ordner "-Feld des Fensters.
1 „Gefällt mir“
Hallo,
Bei mir stürzt dieser Code (vorgeschlagen von @Maclane) SW von Windows 11 25H2 ab (etwas zufällig, aber ziemlich wackelig, daher läuft ich durch Excel).
Ich habe versucht, es zum Laufen zu bringen ( @Maclane Code), aber es ist gescheitert. Außerdem werde ich, falls es auf Version W11 25H2 nicht funktioniert, die Funktionalität über Excel beibehalten.
Der Vorteil der Lösung über Excel (neben ihrer Stabilität) besteht darin, dass es einfach ist, einen vorab ausgewählten Ort für das Öffnen des Windows-Explorer-Fensters einzustellen. (InitialFileName), was sehr praktisch ist.
Bis Mittags!! Ich werde einen Großteil meiner Makros 
anpassen müssen (Schnüffel!) 
... endlich eine Chance , dass @sbadenis die Pflaster vor mir abgewischt hatte... 
1 „Gefällt mir“
Das Problem ist, dass wir Codes verwenden, die sich gerade erst entwickeln (meinerseits muss ich einen ähnlichen Code seit über 6 Jahren verwendet haben).
Es ist wie bei FileSystemObject, bei dem die Aufgabe von Microsoft kommt, im Moment ist es einfach im Windows-Ereignisberichter angemeldet.
1 „Gefällt mir“
… mehr als 13 Jahre für meinen Ältesten ...
Argh!! Schon jetzt aktualisiere ich die Solidworks-API-Funktionen nur, wenn sie nicht mehr funktionieren (obsoleszenz oder Verlassen), und wenn ich mit Windows / Excel zu tun habe, wird es kompliziert.
1 „Gefällt mir“
Andererseits hat mir die Excel-Lösung Folgendes gezeigt:
Ich hatte bereits ein weiteres Excel-Fenster offen, was das Problem erklären könnte.
Das Problem trat auf, nachdem ich das Excel-Fenster geöffnet hatte, um den Ordner nach maximal 5-10 Sekunden auszuwählen. Ich wählte meinen Ordner, klickte auf 'wiederholen' und jetzt geht es wieder los.
Das ist bei mir bei 3-4 Versuchen passiert und nachdem ich die Excel-Datei + Solidworks geschlossen habe, keine Sorgen mehr
1 „Gefällt mir“