Ich habe gerade nachgeschaut und derselbe Fehler wie @m.blt , die Zeile zum Erstellen von DestinationFolderName ist zu niedrig und der Wert wird angefordert, bevor die Variable zugewiesen wird.
Darüber hinaus enthält der Dateiname beim Exportieren bereits eine Erweiterung, sodass Sie etwas wie folgt exportieren:
A.sldprt und die Aufzeichnung funktioniert daher nicht:
Der Code wurde korrigiert, in der Hoffnung, dass Ihr Fehler von dort kam:
' ******************************************************************************
' macro du 19/04/22 by sj
' ******************************************************************************
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swCustProp As CustomPropertyManager
Dim val As String
Dim valout As String
Dim bool As Boolean
Dim INDICE As Boolean
Dim swExportData As SldWorks.ExportPdfData
Dim boolstatus As Boolean
Dim filename As String
Dim FileNamePDF As String
Dim FileNamePART As String
Dim FileNameSTEP As String
Dim lErrors As Long
Dim lWarnings As Long
Dim ActiveConfig As String
Dim sModelFullPath As String
Dim sFilePath As String
Dim NomDossierDestination As String
Dim Ext_PART As String
Dim Ext_STEP As String
Dim errors As Long
Dim warnings As Long
Dim Nomfichier As String
Dim TestStr As String
Ext_PART = ".SLDPRT"
Ext_STEP = ".STEP"
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Controle si un PART ou un ASM est ouvert
If swModel Is Nothing Then
MsgBox "Aucun assemblage ou pièce en cours", vbCritical
End
End If
If swModel.GetType <> swDocASSEMBLY And swModel.GetType <> swDocPART Then
MsgBox "Cette Macro ne fonctionne que sur les assemblages ou les pièces", vbCritical
End
End If
Set swModelDocExt = swModel.Extension
Set swExportData = swApp.GetExportFileData(1)
swExportData.ExportAs3D = True
'Controle si le fichier ouvert a déjà été sauvegardé
filename = swModel.GetPathName
If filename = "" Then
MsgBox "Sauvegarder d'abord le fichier et réessayez", vbCritical
End
End If
ActiveConfig = swApp.GetActiveConfigurationName(filename)
' Recuperation de propriete (changer la valeur entre "" apres Get4 pour changer de propriete à récupérer)
Set swCustProp = swModelDocExt.CustomPropertyManager("")
bool = swCustProp.Get4("DESIGNATION", False, val, valout)
PropDESIGNATION = valout
'Controle si le fichier ouvert a déjà été approuvé
PropINDICE = InputBox("A quel indice souhaitez vous générer les fichiers ?")
If PropINDICE = "" Then
MsgBox "Merci de ne pas laisser le champs vide", vbCritical
Exit Sub
End If
'Controle si le fichier ouvert a déjà été smarté
If PropDESIGNATION = "" Then
MsgBox "SMARTER votre fichier avant d'exécuter la MACRO", vbCritical
End
End If
sModelFullPath = swModel.GetPathName
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
'variable remonté car déclaré en dessous la 1ère utilisation de la variable dans ta version
NomDossierDestination = sFilePath
'Vérifie que le fichier PDF n'existe pas à cet indice avant enregistrement
FileNamePDF = NomDossierDestination & PropDESIGNATION & "_" & PropINDICE & ".PDF"
TestStr = ""
On Error Resume Next
TestStr = Dir(FileNamePDF)
On Error GoTo 0
If TestStr = "" Then
Else
MsgBox "Le fichier PDF existe déjà à cet indice " & vbCrLf & "dans le dossier de l'assemblage : " & vbCrLf & vbCrLf & sFilePath, vbCritical
Exit Sub
End If
'Vérifie que le fichier PART n'existe pas à cet indice avant enregistrement
FileNamePART = NomDossierDestination & (Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)) & "_" & PropINDICE & Ext_PART
TestStr = ""
On Error Resume Next
TestStr = Dir(FileNamePART)
On Error GoTo 0
If TestStr = "" Then
Else
MsgBox "Le fichier PART existe déjà à cet indice" & vbCrLf & "dans le dossier de l'assemblage : " & vbCrLf & vbCrLf & sFilePath, vbCritical
Exit Sub
End If
'Vérifie que le fichier STEP n'existe pas à cet indice avant enregistrement
FileNameSTEP = NomDossierDestination & PropDESIGNATION & "_" & PropINDICE & Ext_STEP
TestStr = ""
On Error Resume Next
TestStr = Dir(FileNameSTEP)
On Error GoTo 0
If TestStr = "" Then
Else
MsgBox "Le fichier STEP existe déjà à cet indice" & vbCrLf & "dans le dossier de l'assemblage : " & vbCrLf & vbCrLf & sFilePath, vbCritical
Exit Sub
End If
'Enregistrer le doc actif en PDF
swModel.ForceRebuild3 True
swModel.ShowNamedView2 "*Isometric", -1
swModel.ViewZoomtofit2
boolstatus = swModelDocExt.SaveAs(FileNamePDF, 0, 0, swExportData, lErrors, lWarnings)
'Enregistrer le doc actif en PART
Set Part = swApp.ActiveDoc
longstatus = Part.SaveAs3(FileNamePART, 0, 0)
'Ouvrir le doc précédent / Enregistrer le doc actif en STEP
Set swPart = swApp.OpenDoc6(FileNamePART, 1, 0, "", errors, warnings)
Set Part = swApp.ActiveDoc
longstatus = Part.SaveAs3(FileNameSTEP, 0, 0)
'Message d'avertissement d'execution de la macro
MsgBox "MACRO TERMINEE :" & vbCrLf & "Contrôler les fichiers PDF3D, PART, STEP", vbInformation
End Sub
