Hi!
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:
In my personal use case these translate to better performance especially with bigger drawing file.
Some drawbacks:
SaveAs methodBelow 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:
Macro:
' 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
try_:
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_
catch_:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:
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))
Next
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)
Next
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
Else
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
Else
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
Else
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
' ? https://forums.pdfforge.org/t/com-interface-2-4-0-how-to-overwrite-a-file/9356/12
' ? Tested in PDFCreator 5.1.1
' ? Workaround: check if file exists and the delete it
If CheckFileExists(folder) Then
' Delete existing file
DeleteFile(folder)
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
PDFCreatorQueue.ReleaseCom
End If
On Error GoTo 0
'Setup and initialize queue
PDFCreatorQueue.Initialize
' 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"
Else
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
PDFCreatorQueue.ReleaseCom
' * 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
DesktopInstanceErrorMessage:
MsgBox "The PDFCreator desktop application is already running, please close it first!"
EndOfSub:
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
Next
Else
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
Else
CheckFileExists = True
End If
End Function
Sub DeleteFile(ByVal FileToDelete As String)
' From
' https://stackoverflow.com/questions/67835/deleting-a-file-in-vba
' First remove readonly attribute, if set
SetAttr FileToDelete, vbNormal
' Then delete the file
Kill FileToDelete
End Sub