Macro to print SOLIDWORKS documents
{ width=500 }
This VBA macro allows to print active SOLIDWORKS document. It is possible to specify the settings for printing: printer name, printer range, orientation, paper size and scale
Settings
To configure settings change the values of constants at the top of the macro as described below
Const PRINTER_NAME As String = "Microsoft Print To PDF" 'full name of the printer
Const PRINT_RANGE As String = "1-3,5" 'range to print. Specify * to print all pages or a range
Const PRINT_ORIENTATION As Integer = swPageSetupOrientation_e.swPageSetupOrient_Landscape 'orientation landscape or portrait
Const PRINTER_PAPER_SIZE As String = "A3" 'Paper size to print to
Const PRINT_SCALE As String = "*" 'Scale of print. Use * to scale to fit or a value of scale % (from 1 to 1000)
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
Dim swApp As SldWorks.SldWorks
Const PRINTER_NAME As String = "Microsoft Print To PDF"
Const PRINT_RANGE As String = "1-3,5"
Const PRINT_ORIENTATION As Integer = swPageSetupOrientation_e.swPageSetupOrient_Landscape
Const PRINTER_PAPER_SIZE As String = "A3"
Const PRINT_SCALE As String = "*"
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
Err.Raise vbError, "", "Please open the document"
End If
Dim swPageSetup As SldWorks.PageSetup
Set swPageSetup = swModel.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 = swModel.Printer
origPrinterPaperSize = swPageSetup.PrinterPaperSize
origScaleToFit = swPageSetup.ScaleToFit
origScale = swPageSetup.Scale2
origOrientation = swPageSetup.Orientation
origUsePageSetup = swModel.Extension.UsePageSetup
swModel.Printer = PRINTER_NAME
swPageSetup.PrinterPaperSize = GetPaper(PRINTER_NAME, PRINTER_PAPER_SIZE)
If PRINT_SCALE = "*" Then
swPageSetup.ScaleToFit = True
Else
swPageSetup.ScaleToFit = False
swPageSetup.Scale2 = CDbl(PRINT_SCALE)
End If
swPageSetup.Orientation = PRINT_ORIENTATION
swModel.Extension.UsePageSetup = swPageSetupInUse_e.swPageSetupInUse_Document
Dim swPrintSpec As SldWorks.PrintSpecification
Set swPrintSpec = swModel.Extension.GetPrintSpecification
swPrintSpec.printRange = GetPrintRange(PRINT_RANGE)
swModel.Extension.PrintOut4 PRINTER_NAME, "", swPrintSpec
swModel.Printer = origPrinter
swPageSetup.PrinterPaperSize = origPrinterPaperSize
swPageSetup.ScaleToFit = origScaleToFit
swPageSetup.Scale2 = origScale
swPageSetup.Orientation = origOrientation
swModel.Extension.UsePageSetup = origUsePageSetup
End Sub
Function GetPrintRange(range As String) As Variant
Dim printRange() As Long
If range = "*" Then
ReDim printRange(1)
printRange(0) = -1
printRange(1) = -1
Else
Dim vPageRanges As Variant
vPageRanges = Split(range, ",")
ReDim printRange((UBound(vPageRanges) + 1) * 2 - 1)
Dim i As Integer
For i = 0 To UBound(vPageRanges)
Dim vStartEndPages As Variant
vStartEndPages = Split(Trim(CStr(vPageRanges(i))), "-")
Dim startPage As Long
Dim endPage As Long
startPage = CLng(vStartEndPages(0))
If UBound(vStartEndPages) = 0 Then
endPage = startPage
ElseIf UBound(vStartEndPages) = 1 Then
endPage = CLng(vStartEndPages(1))
Else
Err.Raise vbError, "", "Invalid page range: " & CStr(vPageRanges(i))
End If
printRange(i * 2) = startPage
printRange(i * 2 + 1) = endPage
Next
End If
GetPrintRange = printRange
End Function
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