Właśnie spojrzałem i ten sam błąd co @m.blt wiersz do utworzenia DestinationFolderName jest zbyt niski i wartość jest wymagana przed przypisaniem zmiennej.
Ponadto nazwa pliku podczas eksportowania zawiera już rozszerzenie, więc eksportujesz coś takiego:
A.sldprt i dlatego nagrywanie nie działa:
Kod został poprawiony w nadziei, że Twój błąd pochodzi stamtąd:
' ******************************************************************************
' 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
