Print to PDF with VBA macro


I’m looking for a way to quickly export a drawing to PDF.

At the moment I’m using a variation of this macro from @artem, which uses the SaveAs method. This works well, but when large files are involved is slow because the file must be saved in order to perform the Save As (am I wrong?)

I thought of printing the drawing with the Microsoft Print to PDF printer, which much quicker, but I don’'t think I can program the destination path with VBA.

Is there some other option?

Thanks in advance.

Check this macro by @artem Macro to print SOLIDWORKS documents

Also check this post Printing to PDF Solidworks macro - DASSAULT: SOLIDWORKS 3D Design - Eng-Tips


Hi! Thanks for the reply.

It seems to me that there is no way to set the exported file path by the macro and not require the user to input it.

I guess I will continue to use SaveAs.

I made some progress on the subject.

I discovered that PDFCreator has a COM interface that can be used in a VBA macro to export to PDF using a virtual printer.

Some advantages of this approach:

  • the drawing do not need to be saved in order to run the macro
  • the process of print a PDF is quicker that saving a PDF

In my personal use case these translate to better performance especially with bigger drawing file.

Some drawbacks:

  • you need to rely on third party software
  • the final PDF are slightly bigger that the one created with the SaveAs method
  • as of PDFCreator 5.1.1 the COM interface do not overwrite existing files in the destination folder, but the new PDF is appended to the existing one. This behavior seems to be present from quite some time (PDF Forge forum). As a work-around a macro needs to check before printing if any PDF with the same name of the exported one exists in the destination folder

Below you can find the code of a macro that export the active sheet of the open drawing in a sub-folder PDF of the folder defined in OUT_FOLDER. File name is composed with the rule in OUT_NAME_TEMPLATES.

Keep in mind that I’m not a developer and that most of the code came from Codestack:


' Export sheet to PDF
' This macro exports the active drawing sheet to PDF

Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, ByRef lpOutput As Any, ByRef lpDevMode As Any) As Long

Const PRINT_RANGE As String = "*"                                                           ' Sheets to print. Use * to print all sheets
Const PRINT_ORIENTATION As Integer = swPageSetupOrientation_e.swPageSetupOrient_Landscape   ' Landscape or portrait orientation
Const PRINT_SCALE As String = "*"                                                           ' Print scale; use * to fill or a % between 1 and 1000

Const OUT_FOLDER As String = "C:\_Export" 'Destination path. Leave blank "" to save in the same folder of the selected file

Dim OUT_NAME_TEMPLATES As Variant 'Export map, just one element

Dim swApp As SldWorks.SldWorks

Sub main()

    OUT_NAME_TEMPLATES = Array("PDF\<_FileName_>_<_ConfName_>.pdf")
    Set swApp = Application.SldWorks
    On Error GoTo catch_ ' Comment this line to debug code without exit the macro
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    Dim swDrawing As SldWorks.DrawingDoc
    If swModel Is Nothing Then
        Err.Raise vbError, "", "Open a document to run the macro"
    End If
    If swModel.GetPathName() = "" Then
        Err.Raise vbError, "", "Save the document to run the macro"
    End If
    If Not swModel.GetType() = swDocumentTypes_e.swDocDRAWING Then
        Err.Raise vbError, "", "Open a drawing to run the macro"
    End If

    Dim outputFolder As String
    outputFolder = PrepareOutput(swModel, OUT_NAME_TEMPLATES, OUT_FOLDER)
    Set swDrawing = swModel
    PrintToPdf swDrawing, outputFolder
    GoTo finally_
    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk

End Sub

Function PrepareOutput(model As SldWorks.ModelDoc2, vOutNameTemplates As Variant, outFolder As String) As String
    Dim swDraw As SldWorks.DrawingDoc
    Set swDraw = model

    Dim sheetName As String
    sheetName = swDraw.GetCurrentSheet().GetName
    Dim errs As Long
    Dim warns As Long

    Dim outNameTemplate As String
    outNameTemplate = vOutNameTemplates(0)
    Dim outFilePath As String
    outFilePath = ComposeOutFileName(outNameTemplate, model, outFolder)

    Dim outDir As String
    outDir = Left(outFilePath, InStrRev(outFilePath, "\"))

    CreateDirectories outDir

    PrepareOutput = outFilePath
End Function

Function ComposeOutFileName(template As String, model As SldWorks.ModelDoc2, outFolder As String) As String

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.IgnoreCase = True
    regEx.Pattern = "<[^>]*>"
    Dim regExMatches As Object
    Set regExMatches = regEx.Execute(template)
    Dim i As Integer
    Dim outFileName As String
    outFileName = template
    For i = regExMatches.Count - 1 To 0 Step -1
        Dim regExMatch As Object
        Set regExMatch = regExMatches.Item(i)
        Dim tokenName As String
        tokenName = Mid(regExMatch.Value, 2, Len(regExMatch.Value) - 2)
        outFileName = Left(outFileName, regExMatch.FirstIndex) & ResolveToken(tokenName, model) & Right(outFileName, Len(outFileName) - (regExMatch.FirstIndex + regExMatch.Length))
    ComposeOutFileName = ReplaceInvalidPathSymbols(GetFullPath(model, outFileName, outFolder))
End Function

Function ReplaceInvalidPathSymbols(path As String) As String
    Const REPLACE_SYMB As String = "_"
    Dim res As String
    res = Right(path, Len(path) - Len("X:\"))
    Dim drive As String
    drive = Left(path, Len("X:\"))
    Dim invalidSymbols As Variant
    invalidSymbols = Array("/", ":", "*", "?", """", "<", ">", "|")
    Dim i As Integer
    For i = 0 To UBound(invalidSymbols)
        Dim invalidSymb As String
        invalidSymb = CStr(invalidSymbols(i))
        res = Replace(res, invalidSymb, REPLACE_SYMB)
    ReplaceInvalidPathSymbols = drive + res
End Function

Function ResolveToken(token As String, model As SldWorks.ModelDoc2) As String
    Const FILE_NAME_TOKEN As String = "_FileName_"
    Const CONF_NAME_TOKEN As String = "_ConfName_"
    Select Case LCase(token)
        Case LCase(FILE_NAME_TOKEN)
            ResolveToken = GetFileNameWithoutExtension(model.GetPathName)
        Case LCase(CONF_NAME_TOKEN)
            If model.GetType() = swDocumentTypes_e.swDocDRAWING Then
                Dim swDraw As SldWorks.DrawingDoc
                Set swDraw = model
                ResolveToken = swDraw.GetCurrentSheet().GetName
                ResolveToken = model.ConfigurationManager.ActiveConfiguration.Name
            End If
        Case Else
            Dim swCustPrpMgr As SldWorks.CustomPropertyManager
            Dim resVal As String
            resVal = ""
            If model.GetType() <> swDocumentTypes_e.swDocDRAWING Then
                Set swCustPrpMgr = model.Extension.CustomPropertyManager(model.ConfigurationManager.ActiveConfiguration.Name)
                swCustPrpMgr.Get2 token, "", resVal
            End If
            If resVal = "" Then
                Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
                swCustPrpMgr.Get2 token, "", resVal
            End If
            ResolveToken = resVal
    End Select
End Function

Function GetFileNameWithoutExtension(path As String) As String
    GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
End Function

Sub CreateDirectories(path As String)

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(path) Then
        Exit Sub
    End If

    CreateDirectories FSO.GetParentFolderName(path)
    FSO.CreateFolder path
End Sub

Function GetFullPath(model As SldWorks.ModelDoc2, path As String, outFolder As String)
    GetFullPath = path
    If IsPathRelative(path) Then
        If Left(path, 1) <> "\" Then
            path = "\" & path
        End If
        If outFolder = "" Then
            Dim modelPath As String
            Dim modelDir As String
            modelPath = model.GetPathName
            modelDir = Left(modelPath, InStrRev(modelPath, "\") - 1)
            outFolder = modelDir
            If Right(outFolder, 1) = "\" Then
                outFolder = Left(outFolder, Len(outFolder) - 1)
            End If
        End If
        GetFullPath = outFolder & path
    End If
End Function

Function IsPathRelative(path As String)
    IsPathRelative = Mid(path, 2, 1) <> ":" And Not IsPathUnc(path)
End Function

Function IsPathUnc(path As String)
    IsPathUnc = Left(path, 2) = "\\"
End Function

Function GetExtension(path As String) As String
    GetExtension = Right(path, Len(path) - InStrRev(path, "."))
End Function

Sub PrintToPdf(drawModel As SldWorks.ModelDoc2, folder As String)
    Dim swDraw As SldWorks.DrawingDoc
    Set swDraw = drawModel

    ' * Get sheet names
    Dim vSheetNames As Variant
    vSheetNames = swDraw.GetSheetNames
    Dim activeSheet As String
    activeSheet = swDraw.GetCurrentSheet().GetName
    Dim swActiveSheet As SldWorks.sheet
    Set swActiveSheet = swDraw.sheet(activeSheet)

    ' * Page setup
    ' Get sheet dimension: A4=6 A4V=7 A3=8; A2=9 A1=10 A0=11
    Dim curSize As Integer
    curSize = swActiveSheet.GetSize(-1, -1)
    Dim DimPagina As String

    Select Case curSize
        Case Is = 6
            DimPagina = "A4"
        Case Is = 8
            DimPagina = "A3"
        Case Is = 9
            DimPagina = "A2"
        Case Is = 10
            DimPagina = "A1"
        Case Is = 11
            DimPagina = "A0"
        Case Else
            Err.Raise vbError, "", "Sheet dimension not supported"
    End Select
    ' Set printer name
    Dim namePrinter As String
    namePrinter = "PDFCreator"
    Dim swPageSetup As SldWorks.PageSetup
    Set swPageSetup = drawModel.PageSetup

    Dim origPrinter As String
    Dim origPrinterPaperSize As Integer
    Dim origScaleToFit As Boolean
    Dim origScale As Double
    Dim origOrientation As Integer
    Dim origUsePageSetup As Integer

    origPrinter = drawModel.Printer
    origPrinterPaperSize = swPageSetup.PrinterPaperSize
    origScaleToFit = swPageSetup.ScaleToFit
    origScale = swPageSetup.Scale2
    origOrientation = swPageSetup.Orientation
    origUsePageSetup = drawModel.Extension.UsePageSetup

    swPageSetup.PrinterPaperSize = GetPaper(namePrinter, DimPagina)

    If PRINT_SCALE = "*" Then
        swPageSetup.ScaleToFit = True
        swPageSetup.ScaleToFit = False
        swPageSetup.Scale2 = CDbl(PRINT_SCALE)
    End If

    swPageSetup.Orientation = PRINT_ORIENTATION

    swPageSetup.DrawingColor = swPageSetupDrawingColor_e.swPageSetup_ColorGrey

    drawModel.Extension.UsePageSetup = swPageSetupInUse_e.swPageSetupInUse_Document

    Dim swPrintSpec As SldWorks.PrintSpecification
    Set swPrintSpec = drawModel.Extension.GetPrintSpecification

    ' Get active sheet number
    Dim activeSheetNbr As Long
    activeSheetNbr = GetSheetNumber(swDraw, swActiveSheet)

    ' Set print range
    Dim printRangeArray() As Long            
    ReDim printRangeArray(1)            
    printRangeArray(0) = activeSheetNbr
    printRangeArray(1) = activeSheetNbr

    swPrintSpec.printRange = printRangeArray

    ' * Prepare PDFCreator

    ' ? PDFCreator is merging files if one with the same name exists
    ' ?
    ' ? Tested in PDFCreator 5.1.1
    ' ? Workaround: check if file exists and the delete it

    If CheckFileExists(folder) Then

        ' Delete existing file

    End If

    Dim PDFCreatorQueue As Variant
    Dim printJob As Variant

    Set PDFCreatorQueue = CreateObject("PDFCreator.JobQueue")
    ' PDFCreatorQueue.ReleaseCom

    'Check if another instance of PDFCreator is already running. If it's a desktop instance, display an error message.
    If IsPDFCreatorRunning Then
        On Error GoTo DesktopInstanceErrorMessage
    End If

    On Error GoTo 0

    'Setup and initialize queue

    ' Print the model
    drawModel.Extension.PrintOut4 namePrinter, "", swPrintSpec

    If Not PDFCreatorQueue.WaitForJob(10) Then
        MsgBox "The print job did not reach the queue within " & " 10 seconds"
        Set printJob = PDFCreatorQueue.NextJob
        'Configure settings for the current job. You always need to configure an output path,
        printJob.SetProfileByGuid ("DefaultGuid")
        printJob.SetProfileSetting "AttachmentPage.Enabled", "False"
        printJob.SetProfileSetting "BackgroundPage.Enabled", "False"

        'After configuring the settings, start the conversion
        printJob.ConvertTo (folder)
        'Check if job was successful
        If (Not printJob.IsFinished Or Not printJob.IsSuccessful) Then
            MsgBox "Could not convert!"
        End If
    End If

    ' * End of PDFCreator setup

    drawModel.Printer = origPrinter
    swPageSetup.PrinterPaperSize = origPrinterPaperSize
    swPageSetup.ScaleToFit = origScaleToFit
    swPageSetup.Scale2 = origScale
    swPageSetup.Orientation = origOrientation
    drawModel.Extension.UsePageSetup = origUsePageSetup

    GoTo EndOfSub

        MsgBox "The PDFCreator desktop application is already running, please close it first!"


End Sub

Function GetPaper(printerName As String, paperName As String) As Integer
    Const DC_PAPERNAMES As Integer = &H10
    Const DC_PAPERS As Integer = &H2
    Dim papersCount As Integer
    papersCount = DeviceCapabilities(printerName, "", DC_PAPERS, ByVal vbNullString, 0)
    If papersCount > 0 Then
        Dim papersCodes() As Integer
        ReDim papersCodes(papersCount - 1)
        DeviceCapabilities printerName, "", DC_PAPERS, papersCodes(0), 0
        Dim papersNames As String
        papersNames = String$(64 * papersCount, 0)
        DeviceCapabilities printerName, "", DC_PAPERNAMES, ByVal papersNames, 0
        Dim i As Integer
        For i = 0 To papersCount
            If LCase(ParsePaperName(papersNames, 64 * i + 1)) = LCase(paperName) Then
                GetPaper = papersCodes(i)
            End If
        Err.Raise vbError, "", "No sizes available for the specified printer"
    End If
End Function

Function ParsePaperName(papersNames As String, offset As Integer) As String

    Dim paperName As String
    paperName = Mid(papersNames, offset, 64)
    Dim nullCharIndex As Integer
    nullCharIndex = InStr(paperName, vbNullChar)
    If nullCharIndex <> 0 Then
        paperName = Left$(paperName, nullCharIndex - 1)
    End If
    ParsePaperName = paperName
End Function

Function GetSheetNumber(drawingDocument As SldWorks.DrawingDoc, sheet As SldWorks.Sheet) As Long

    Dim swSheetNames As Variant
    swSheetNames = drawingDocument.GetSheetNames

    Dim SheetNumber As Long
    Dim i As Integer

    For i = 1 To UBound(swSheetNames) + 1

        If sheet.GetName = swSheetNames(i - 1) Then

            SheetNumber = i

            Exit For

        End If

    Next i

    GetSheetNumber = SheetNumber

End Function

Function CheckFileExists(path As String) As Boolean

    Dim strFileExists As String
    strFileExists = Dir(path)

    If strFileExists = "" Then
        CheckFileExists = False
        CheckFileExists = True
    End If

End Function

Sub DeleteFile(ByVal FileToDelete As String)

    ' From
    ' First remove readonly attribute, if set
    SetAttr FileToDelete, vbNormal          
    ' Then delete the file
    Kill FileToDelete

End Sub