Macro save as 3D PDF

Out of category
1

Hello I'm looking to make a macro to save under an assembly or a part in 3D PDF, but I don't know how to do it. I did find something with "ExportAs3D" but I don't know how to integrate it into my code. Does anyone have the solution?

Option Explicit
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData          As SldWorks.ExportPdfData
    Dim boolstatus          As Boolean
    Dim filename            As String
    Dim lErrors             As Long
    Dim lWarnings           As Long
    Dim ActiveConfig As String
    
'Dim instance As IExportPdfData
'Dim value As System.Boolean
'
'instance.ExportAs3D = value
'value = instance.ExportAs3D
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    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(swExportPdfData)
    filename = swModel.GetPathName
    If filename = "" Then
        MsgBox "Sauvegarder d'abord le fichier et réessayez", vbCritical
        End
    End If
       
    ActiveConfig = swApp.GetActiveConfigurationName(filename)
    
    Dim NomDossierDestination As String
    NomDossierDestination = "C:\Users\Edouard\Desktop\"
  
    swModel.ForceRebuild3 True
    swModel.ShowNamedView2 "Dimetric", 9
    swModel.ViewZoomtofit2
  
    filename = NomDossierDestination & ActiveConfig & ".PDF"
    
    '-------------------------------------------------------------------------------------

    boolstatus = swExportData.SetSheets(swExportData_ExportAllSheets, 1)
    boolstatus = swModelDocExt.SaveAs(filename, 0, 0, swExportData, lErrors, lWarnings)
    If boolstatus Then
        MsgBox "Enregistrement au format PDF 3D réussi" & vbNewLine & filename
    Else
        MsgBox "Echec de l'enregistrement au format PDF 3D, Error code:" & lErrors
    End If
End Sub

 

2

Hello, It should be this:

Option Explicit
Sub main()
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData        As SldWorks.ExportPdfData
    Dim boolstatus          As Boolean
    Dim filename            As String
    Dim lErrors             As Long
    Dim lWarnings           As Long
    Dim ActiveConfig As String
    Dim NomDossierDestination As String
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    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
    
    filename = swModel.GetPathName
    If filename = "" Then
        MsgBox "Sauvegarder d'abord le fichier et réessayez", vbCritical
        End
    End If

    ActiveConfig = swApp.GetActiveConfigurationName(filename)

    NomDossierDestination = "C:\Users\Edouard\Desktop\"
    filename = NomDossierDestination & ActiveConfig & ".PDF"
    swModel.ForceRebuild3 True
    swModel.ShowNamedView2 "Dimetric", 9
    swModel.ViewZoomtofit2
    boolstatus = swModelDocExt.SaveAs(filename, 0, 0, swExportData, lErrors, lWarnings)
    If boolstatus Then
        MsgBox "Enregistrement au format PDF 3D réussi" & vbNewLine & filename
    Else
        MsgBox "Echec de l'enregistrement au format PDF 3D, Error code:" & lErrors
    End If
End Sub

 

2 Likes
3

thank you JeromeP that's exactly it:)

4

Hello, great macro ! I got it back to make my own but with a few modifications. I modified so that the document renames itself with the name of the file and saves in the same document as the one I created . I just want to add PDF3D to the end of my output file but I can't. I'm a big novice when it comes to creating macros, can you tell me or modify what I've created to make it work? 

 Explicit option
Dim swApp               As SldWorks.SldWorks   
Dim swModel             As SldWorks.ModelDoc2   
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportData        As SldWorks.ExportPdfData
Dim sPathName           As String   
Dim boolstatus          As Boolean   
    Dim filename            As String
    Dim lErrors             As Long
Dim lWarnings           As Long   
    Dim ActiveConfig As String
    Dim FolderNameDestination As String
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "No assembly or part in progress", vbCritical
        End
    End If
    If swModel.GetType <> swDocASSEMBLY And swModel.GetType <> swDocPART Then
        MsgBox "This Macro only works on Assemblies or Parts", vbCritical
        End
    End If
    Set swModelDocExt = swModel.Extension
    Set swExportData = swApp.GetExportFileData(1)
    swExportData.ExportAs3D = True
    
    filename = swModel.GetPathName
    If filename = "" Then
        MsgBox "Save the file first and try again", vbCritical
        End
    End If
    
ActiveConfig = swApp.GetActiveConfigurationName(filename)

    DestinationFolderName = "C:\Users\Position5\Documents\Projects\"
    filename = swModel.GetPathName
    filename = Strings.Left(filename, Len(filename) - 7) + ".PDF"
    swModel.ForceRebuild3 True
    swModel.ShowNamedView2 "Dimetric", 9
    swModel.ViewZoomtofit2
    boolstatus = swModelDocExt.SaveAs(filename, 0, 0, swExportData, lErrors, lWarnings)

    If boolstatus Then
        MsgBox "Successful 3D PDF Registration" & vbNewLine & filename
    Else
        MsgBox "Failed to save as 3D PDF, Error code:" & lErrors
    End If
End Sub

5

filename = Strings.Left(filename, Len(filename) - 7) + "-PDF3D.PDF"

Something like this should work

1 Like
6

Thank you!!