Macro: Save all sheet(s) as PDF except last

Discussion created by Deepak Gupta on Jan 1, 2018
Latest reply on Jan 9, 2020 by Matthew McCartin

Like • Show 2 Likes2
Comment • 9

Macro to save all sheet(s) in the active drawing as PDF except for the last sheet. Macro would prompt you to select a folder.

Please backup your data before using the macro.

The macro is made in SW2018 version but should work on lower version also. In case you're running a different version then update/correct the macro reference as suggested here (don't worry on the fact that video is for fixing missing library error but check the process to update your macro library): Fix-Update SOLIDWORKS Macro References

Attachments

Save All Sheets (except last sheet) As PDF.swp.zip8.8 KB

Outcomes

9 Replies

John Stoltzfus Feb 7, 2019 6:43 AM
Thanks Deepak Gupta
Like • Show 3 Likes3
Actions
Ruben Balderrama Feb 7, 2019 6:54 AM
Cool, again buddy! Thanks..
Like • Show 2 Likes2
Actions
Matthew McCartin Jan 8, 2020 11:32 AM
anyway to edit this so i only get the last sheet?
Like • Show 1 Like1
Actions
- Matthew McCartin @ Matthew McCartin on Jan 8, 2020 12:58 PM
  think i half fixed it? this version is for DXFS however the bend lines still show on the dxf any idea what i can add to this macro that will suppress bend lines?
  
  steps: Tools> Macro>new
  copy this macro
  vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
  
  ' Save All Sheets (except last) As PDF.swp -------------------------------- 01/01/18
  '
  ' Description: Macro to save all sheets except last sheet in the active drawing as PDF.
  '
  ' Preconditions: The drawing document is open.
  '
  ' Postconditions: All sheets except last sheet are exported as PDF in the specified folder with file name as specified.
  ' Folder Browse Codes: http://www.cpearson.com/excel/browsefolder.aspx
  ' Please back up your data before use and USE AT OWN RISK
  '
  '------------------------------------------------------------------------------------
  ' Created by Deepak Gupta (Boxer's SOLIDWORKS Blog, India) http://gupta9665.com/
  '------------------------------------------------------------------------------------
  ' Disclaimer:
  ' This macro is provided as is. No claims, support, refund, safety net, or
  ' warranties are expressed or implied. By using this macro and/or its code in
  ' any way whatsoever, the user and any entities which the user represents,
  ' agree to hold the authors free of any and all liability.
  ' Free distribution and use of this code in other free works is welcome.
  ' You may redistribute it and/or modify it on the condition that this header is retained.
  ' All other forms of distribution (i.e., not free, fee for delivery, etc) are prohibited
  ' without the expressed written consent by the authors.
  ' Use at your own risk!
  ' ------------------------------------------------------------------------------
  Option Explicit
  Private Const BIF_RETURNONLYFSDIRS As Long = &H1
  Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
  Private Const BIF_RETURNFSANCESTORS As Long = &H8
  Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
  Private Const BIF_BROWSEFORPRINTER As Long = &H2000
  Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
  Private Const MAX_PATH As Long = 260
  Function BrowseFolder(Optional Caption As String, _
  Optional InitialFolder As String) As String
  Dim SH As Shell32.Shell
  Dim F As Shell32.Folder
  Set SH = New Shell32.Shell
  Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
  If Not F Is Nothing Then
  BrowseFolder = F.Items.Item.Path
  End If
  End Function
  Sub Main()
  Dim swApp As SldWorks.SldWorks
  Dim swModel As SldWorks.ModelDoc2
  Dim swExportPDFData As SldWorks.ExportPdfData
  Dim sFilePath As String
  Dim sFilename As String
  Dim nErrors As Long
  Dim nWarnings As Long
  Dim bRet As Boolean
  Dim vSheetNames As Variant
  Dim varSheetCount As Variant
  
  On Error GoTo error
  Set swApp = Application.SldWorks
  Set swModel = swApp.ActiveDoc
  Set swExportPDFData = swApp.GetExportFileData(1)
  If (swModel Is Nothing) Or (swModel.GetType <> swDocDRAWING) Then
  swApp.SendMsgToUser ("To be used for drawings only, Open a drawing first and then TRY!")
  Exit Sub
  End If
  'Set File name
  sFilename = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))
  sFilename = Left(sFilename, InStrRev(sFilename, "."))
  
  ' Set Save Path
  sFilePath = BrowseFolder()
  If sFilePath = "" Then
  MsgBox "Please select the path and try again"
  End
  Else
  sFilePath = sFilePath & "\"
  End If
  
  vSheetNames = swModel.GetSheetNames
  varSheetCount = swModel.GetSheetCount()
  
  ReDim Preserve vSheetNames(varSheetCount - 2)
  
  swExportPDFData.SetSheets swExportData_ExportSpecifiedSheets, vSheetNames
  swExportPDFData.ViewPdfAfterSaving = False
  bRet = swModel.Extension.SaveAs(sFilePath & sFilename & ".DXF", 0, 0, swExportPDFData, nErrors, nWarnings)
  Exit Sub
  error:
  MsgBox "An error has occured - Please close and reopen SOLIDWORKS to try again", vbCritical, "Program Error"
  Exit Sub
  End Sub
  Like • Show 1 Like1
  Actions
  - Matthew McCartin @ Matthew McCartin on Jan 8, 2020 3:48 PM
    So far these are my attempts: bold=run-time error
    
    put this right before the "end sub"
    
    "Boolstatus = Part.ActivateView("Drawing View5")
    Boolstatus = Part.Extension.SelectByID2("BoundaryBox@Part@Drawing View5", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.UnblankSketch"
    
    Boolstatus = Part.ActivateView(Drawing)
    
    when =
    
    Boolstatus = Part.ActivateView("Drawing View5")
    Boolstatus = Part.Extension.SelectByID2("BoundaryBox@Part@Drawing View5", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.UnblankSketch ""
    
    i get a run time error '13' for type mismatch
    
    For i = 0 To UBound(vChildComp)
    
    current variation in macro:
    
    Boolstatus = swChildModel.ShowConfiguration2(swCurrent)
    
    no issue^
    Like • Show 1 Like1
    Actions
    - Deepak Gupta @ Matthew McCartin on Jan 9, 2020 10:47 AM
      Are you looking to export flat pattern view of the sheet metal model from drawing? If yes then you can use a different macro.
      Like • Show 2 Likes2
      Actions
      - Matthew McCartin @ Deepak Gupta on Jan 9, 2020 11:28 AM
        I've figured it out a little more by altering some other macros (still not much of a clue what i'm doing but I've gotten kinda far, will post my macro at end) so far my macro can be launched in and assembly, then it opens each individual part and saves them as DXF's and PDF's and puts them into a "PDF's" and "DXF's" folder (would be nice to also have sorted by thickness DXF's), before i was having issues using the macro and suppressing all bend lines in the DXF files for our laser (no clue how i removed them just slowly testing out deleted lines). but now i'm trying to save the PDF's except for the last page (or a named sheet). I've seen some Macro's on here talking about doing some of that stuff but their macros don't work. I'm using Solidworks 2018. Again thanks for responding so fast! and I've heard great things about your work, Deepak Gupta
        
        goals of my macro
        macro runs in assembly (works!)
        select only sheet metal parts of an assembly for DXF's (works!)
        when making PDF's do not save last page, or do not save specific named sheet (cant figure this damn one out but theirs another macro ill link)
        
        Macro I've been editing:
        
        '***********************************************************************
        '* OK, this isn't the tidiest bit of code I've ever written *
        '* & it's mostly cobbled together from examples in the Solidworks API *
        '* Documentation - but it works OK! *
        '* To use, you need to have an assembly open. It will find all the *
        '* linked drawings (must have same name as model) and export to PDF *
        '* It then finds all the SheetMetal parts, exports them to DXF and *
        '* builds a BOM for them - to be sent to your favorite Laser Cutter *
        '* *
        '* Mail me at simon1@psi-design.co.uk if you want to tell be how cool *
        '* you think it is! (or tell me if you've found a problem!) *
        '***********************************************************************
        Option Explicit
        Dim swExportPDFData As SldWorks.ExportPdfData
        
        Sub ShowAllOpenFiles()
        Dim swDoc As SldWorks.ModelDoc2
        Dim swAllDocs As EnumDocuments2
        Dim FirstDoc As SldWorks.ModelDoc2
        Dim NumDocsReturned As Long
        Dim DocCount As Long
        Dim swApp As SldWorks.SldWorks
        Dim bDocWasVisible As Boolean
        Dim OpenWarnings As Long
        Dim OpenErrors As Long
        Dim DwgPath As String
        Dim myDwgDoc As SldWorks.ModelDoc2
        Dim drwPathName As String
        Dim pdfPathName As String
        Dim pdfFolderName As String
        Dim lErrors As Long
        Dim lWarnings As Long
        Dim sMessage As String
        Dim nExported As Integer
        Dim fso As Scripting.FileSystemObject
        Dim FeatureDefinition As SheetMetalFeatureData
        Dim CompConfig As String
        Dim prtPath As String
        Dim featureMgr As Feature
        Dim SheetMetalFolder As Folder
        Set swApp = Application.SldWorks
        Set swAllDocs = swApp.EnumDocuments2
        Set FirstDoc = swApp.ActiveDoc
        On Error Resume Next
        
        If FirstDoc.GetType <> swDocASSEMBLY Then
        MsgBox "I'm afraid this macro only works when run" & vbCr & "from within a top level assembly!"
        Exit Sub
        End If
        
        CompConfig = FirstDoc.ConfigurationManager.ActiveConfiguration.Name
        nExported = 0
        DocCount = 0
        swAllDocs.Reset
        swAllDocs.Next 1, swDoc, NumDocsReturned
        While NumDocsReturned <> 0
        bDocWasVisible = swDoc.Visible
        'swApp.ActivateDoc swDoc.GetPathName'
        DwgPath = swDoc.GetPathName
        If (LCase(Right(DwgPath, 3)) = "prt") Then
        'Open model
        'Export any sheet metal parts as DXF Flat patterns
        prtPath = Left(DwgPath, Len(DwgPath) - 3) & "prt"
        Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocPART, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
        Set featureMgr = myDwgDoc.FeatureManager
        Set SheetMetalFolder = featureMgr.GetSheetMetalFolder
        
        End If
        If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then
        DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"
        Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
        
        If Not myDwgDoc Is Nothing Then
        swApp.ActivateDoc myDwgDoc.GetPathName
        
        'Extract the root folder for assembly and create a PDF folder inside
        pdfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "PDF Drawings\"
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        If (Not fso.FolderExists(pdfFolderName)) Then
        MkDir pdfFolderName
        End If
        
        Dim Part As ModelDoc2
        Set Part = swApp.ActiveDoc()
        
        'You have a drawing active
        drwPathName = Part.GetPathName()
        
        If ("" = drwPathName) Then
        ' GetPathName() was empty
        MsgBox ("This drawing has not been saved yet")
        Exit Sub
        End If
        
        pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) & "-" & CompConfig & ".pdf")
        
        Set swExportPDFData = swApp.GetExportFileData(1)
        swExportPDFData.ViewPdfAfterSaving = False
        Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings
        
        swApp.QuitDoc (Part.GetTitle)
        Set myDwgDoc = Nothing
        nExported = nExported + 1
        End If
        End If
        
        swAllDocs.Next 1, swDoc, NumDocsReturned
        DocCount = DocCount + 1
        Wend
        
        sMessage = "PDF/DXF/BOM Export " & vbCr & vbCr
        If nExported = 0 Then
        sMessage = sMessage & "No Drawings found to export to PDF" & vbCr & vbCr
        Else
        sMessage = sMessage & CStr(nExported) & " PDF's saved to: " & vbCr & pdfFolderName & vbCr & vbCr
        End If
        
        swApp.ActivateDoc FirstDoc.GetPathName
        'Generate & save the BOM for sheet metal parts
        sMessage = sMessage & ExportSheetBOM() 'Returns info on DXF's exported if any
        
        MsgBox sMessage
        End Sub
        
        Function ExportSheetBOM() As String
        'Counts the instances of sheet metal parts in Assembly (and su=assemblies)
        Dim swApp As SldWorks.SldWorks
        Dim swDoc As SldWorks.ModelDoc2
        Dim swMyDoc As SldWorks.ModelDoc2
        Dim swAssy As SldWorks.AssemblyDoc
        Dim swSelMgr As SldWorks.SelectionMgr
        Dim swSelComp As SldWorks.Component2
        Dim CurSelCount As Long
        Dim GeneralSelObj As Object
        Dim AllComponents As Variant
        Dim i As Long
        Dim TopLevOnly As Boolean
        Dim SupCount As Long
        Dim LwtCount As Long
        Dim ResCount As Long
        Dim sMsg As String
        Dim CompPath As String
        Dim CompConfig As String
        Dim EachComp As SldWorks.Component2
        'Bill of Materials
        Dim sPartNames() As String
        Dim nPartQty() As Integer
        Dim sPartMaterial() As String
        Dim sPartThickness() As String
        Dim nCnt As Integer
        Dim FeatureDefinition As SheetMetalFeatureData
        Dim nThickness As Double
        Dim sMatDB As String
        Dim OpenWarnings As Long
        Dim OpenErrors As Long
        Dim mFSO As Scripting.FileSystemObject
        Dim prtPath As String
        Dim featureMgr As Feature
        Dim firstfeature As Feature
        Dim SheetMetalFolder As Folder
        Dim nextfeature As Feature
        Dim Thickness As Double
        Dim bRebuild As Boolean
        Dim bRet As Boolean
        Dim sBOM As String
        Dim ComponentRoot As String
        Dim ComponentName As String
        Dim Material As String
        Dim DwgPath As String
        Dim EachName As String
        Dim dxfFolderName As String
        Dim dxfFileName As String
        Dim NewFilePath As String
        Dim fso As Scripting.FileSystemObject
        Dim nDXFExported As Integer
        Dim bFound As Boolean
        Dim objTextStream As Object
        'Dim swSelMgr As SldWorks.SelectionMgr
        Dim swView As SldWorks.View
        Dim swDrawModel As SldWorks.ModelDoc2
        Dim myDwgDoc As SldWorks.ModelDoc2
        Dim pdfFolderName As String
        Dim drwPathName As String
        Dim pdfPathName As String
        Dim lErrors As Long
        Dim lWarnings As Long
        Dim nExported As Integer
        Dim fsoForWriting As Variant
        Dim sDXFPath As String
        On Error Resume Next
        ReDim Preserve sPartNames(0)
        ReDim Preserve nPartQty(0)
        ReDim Preserve sPartMaterial(0)
        ReDim Preserve sPartThickness(0)
        
        Set swApp = Application.SldWorks
        Set swDoc = swApp.ActiveDoc
        
        Set swAssy = swDoc
        
        Set swSelMgr = swDoc.SelectionManager
        
        CompPath = swDoc.GetPathName
        CompPath = swSelMgr.GetPathName
        'Find component name.
        ComponentRoot = Left(CompPath, InStrRev(CompPath, "\"))
        ComponentName = Mid(CompPath, InStrRev(CompPath, "\") + 1)
        ComponentName = Left(ComponentName, InStrRev(ComponentName, ".") - 1)
        
        CompConfig = swDoc.ConfigurationManager.ActiveConfiguration.Name
        
        TopLevOnly = False
        
        AllComponents = swAssy.GetComponents(TopLevOnly)
        
        SupCount = 0
        ResCount = 0
        LwtCount = 0
        
        For i = 0 To UBound(AllComponents)
        Set EachComp = AllComponents(i)
        
        Set firstfeature = EachComp.firstfeature
        Set nextfeature = firstfeature.GetNextFeature
        Material = "Not Set"
        Do While (Not (firstfeature Is Nothing))
        If nextfeature.GetTypeName = "SheetMetal" Then
        'This part has sheet metal
        Set FeatureDefinition = nextfeature.GetDefinition
        Set swMyDoc = swApp.OpenDoc6(EachComp.GetPathName, swDocPART, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
        
        DwgPath = swMyDoc.GetPathName
        EachName = Mid(EachComp.GetPathName, InStrRev(EachComp.GetPathName, "\") + 1)
        EachName = Left(EachName, InStrRev(EachName, ".") - 1)
        bRebuild = swMyDoc.ForceRebuild3(False)
        
        dxfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "DXF Flat Patterns\"
        dxfFileName = Mid(DwgPath, InStrRev(DwgPath, "\") + 1)
        'Loose Extension
        dxfFileName = Left(dxfFileName, InStrRev(dxfFileName, ".") - 1)
        
        NewFilePath = dxfFolderName & dxfFileName & "-" & CompConfig & ".DXF"
        
        'Now create path
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        If (Not fso.FolderExists(dxfFolderName)) Then
        MkDir dxfFolderName
        End If
        
        Set fso = Nothing 'destroy object
        
        'Export Flat Pattern
        bRet = swMyDoc.ExportFlatPatternView(NewFilePath, 1)
        nDXFExported = nDXFExported + 1
        
        Material = swMyDoc.MaterialIdName
        If InStr(Material, "SOLIDWORKS Materials|") > 0 Then
        Material = Mid(Material, InStr(Material, "SOLIDWORKS Materials|") + 21)
        End If
        If InStr(Material, "|") > 0 Then
        Material = Left(Material, InStr(Material, "|") - 1)
        End If
        
        Thickness = FeatureDefinition.Thickness * 1000 'put in to mm
        
        'Look through array for component name
        bFound = False
        For nCnt = 1 To UBound(sPartNames)
        If UCase(sPartNames(nCnt)) = UCase(EachName) Then
        'Inc qty
        nPartQty(nCnt) = nPartQty(nCnt) + 1
        bFound = True
        End If
        Next
        If Not bFound Then
        ReDim Preserve sPartNames(UBound(sPartNames) + 1)
        ReDim Preserve nPartQty(UBound(sPartNames) + 1)
        ReDim Preserve sPartMaterial(UBound(sPartNames) + 1)
        ReDim Preserve sPartThickness(UBound(sPartNames) + 1)
        sPartNames(UBound(sPartNames)) = EachName
        nPartQty(UBound(sPartNames)) = 1
        sPartThickness(UBound(sPartNames)) = Thickness
        sPartMaterial(UBound(sPartNames)) = Material
        End If
        swApp.QuitDoc (swMyDoc.GetTitle)
        End If
        
        Set firstfeature = nextfeature.GetNextFeature
        If (Not (firstfeature Is Nothing)) Then
        'Debug.Print nextfeature.GetTypeName
        Set nextfeature = firstfeature
        End If
        Loop
        
        Next i
        If UBound(sPartNames) > 0 Then
        'We should now have an array we can save as a CSV
        'Finally Export a CSV of the BOM
        'Extract the root folder for assembly and create a DXF folder inside
        sDXFPath = Left(swDoc.GetPathName, InStrRev(swDoc.GetPathName, "\")) & "DXF Flat Patterns\"
        Dim objFSO
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'Close the file and clean up
        objTextStream.Close
        Set objTextStream = Nothing
        Set objFSO = Nothing
        If nDXFExported > 0 Then
        
        Else
        ExportSheetBOM = "No DXF's Exported" & vbCr & vbCr
        End If
        End If
        End Function
        Like • Show 1 Like1
        Actions
        Matthew McCartin @ Matthew McCartin on Jan 9, 2020 11:41 AM
        you had created a macro (Macro: Save all sheet(s) as PDF except last ) however it only works in drawings. is their a way to edit this macro so it can be opened in an Assembly, and save the PDF's to a selected file location.
        Like • Show 1 Like1
        Actions
        Matthew McCartin @ Matthew McCartin on Jan 9, 2020 11:55 AM
        Help Batch Saving Drawings As PDF - Configuration Specific Properties in File Name
        
        this macro only selects non sheet metal parts and makes a pdf folder for pdf's
        Like • Show 1 Like1
        Actions

Macro: Save all sheet(s) as PDF except last

Attachments

Outcomes

Related Content

Recommended Content

Incoming Links