2 Replies Latest reply on Apr 10, 2018 12:41 PM by Arthur McRae

    Adding to Save as PDF Macro

    Andrew Boulton

      Hi,

       

      I currently have a macro setup to save current drawing file as a pdf in a different location (saving as file name). This works great but it saves the ENTIRE drawing file. I'd like to send another copy of only sheets containing "Assembly" to another location in a PDF. I saw a similar example with someone wanting to create a PDF of all sheets not containing "FLAT" and tried manipulating that code but to no avail.

       

      Can anyone help or point to a similar thread?

        • Re: Adding to Save as PDF Macro
          Deepak Gupta

          Check this macro if codes can help you Save all sheet(s) as PDF except last

          • Re: Adding to Save as PDF Macro
            Arthur McRae

            This is our Save As Macro:

             

            Option Explicit

            Dim swApp           As SldWorks.SldWorks

            Dim swDoc           As SldWorks.ModelDoc2

            Dim swModelDocExt   As SldWorks.ModelDocExtension

            Dim swCustProp      As CustomPropertyManager

             

             

            Dim boolstatus      As Boolean

            Dim longstatus      As Long, longwarnings As Long

            Dim Prop_N()        As String

            Dim iReply          As String

            Dim saveDir         As String, FileDir As String, FileName As String, sRev As String, sP_Numb As String, sStatus As String

            Dim FileExt(1 To 2) As String

            Dim FileChk         As Boolean

             

             

             

             

            '-----------------------------------------------------------------------------------'

            Sub main()

             

             

            Set swApp = Application.SldWorks

            Set swDoc = swApp.ActiveDoc

            'check that a File is open

            If swDoc Is Nothing Then

            iReply = "No File open"

            MsgBox iReply

            End

            End If

            Set swModelDocExt = swDoc.Extension

            Set swCustProp = swModelDocExt.CustomPropertyManager("")

            '

            Prop_N() = Split("Status, PROJECT NO, Revision, CheckedBy, Description", ", ")

            '

            'iReply = "WARNING! Macro underdevelopment"

            'MsgBox iReply

             

             

            'Checks to make sure current file is a drawing

            If swDoc.GetType <> swDocDRAWING Then

            FrmDrwChk.Show

            sRev = 1

            Else

            Dim I As Integer

            Dim val As String, valout As String

            For I = 0 To UBound(Prop_N)

            boolstatus = swCustProp.Get4(Prop_N(I), False, val, valout)

            'Debug.Print "Value:                    " & val

            'Debug.Print "Evaluated value:          " & valout

            'Debug.Print "Up-to-date data:          " & boolstatus

            Select Case I

                    Case 0

                    sStatus = valout

                    Case 1

                    sP_Numb = valout

                    Case 2

                    sRev = valout

                    Case 3

                    If valout <> " " Or valout <> "" Or UCase(valout) <> "XX" Then

                    Debug.Print "Checked by:                " & valout

                    FileChk = True

                    Else

                    FileChk = False

                    End If

                    Case 4

                    Debug.Print "Description:               " & valout

                    Case Else

                    MsgBox "Unrecognized Property"

            End Select

            Next I

            End If

            'set up file extensions

            FileExt(1) = ".PDF"

            FileExt(2) = ".EDRW"

            'Gets current file name and path

            FileName = swDoc.GetPathName

            Debug.Print FileName

            'strips solidworks extension off name and replaces with pdf

            FileDir = Left(FileName, Len(FileName) - 7)

            If InStr(UCase(FileDir), "MODEL") = 0 Then

            saveDir = Left(FileDir, InStrRev(FileDir, "\"))

            Else: saveDir = Left(FileDir, InStr(UCase(FileDir), "MODEL") + 5) & "PUBLISHED\"

            End If

            FileName = Right(FileDir, Len(FileDir) - InStrRev(FileDir, "\"))

             

             

            'Revison format

            If sRev = CStr("1") Or sRev = "" Then

            sRev = ""

            Else

            sRev = "_R" & sRev

            End If

             

             

            'Project Number Format

            'sP_Numb = Mid(sP_Numb, 2, 5)

            'If IsNumeric(sP_Numb) = True Then

            'sP_Numb = "P" & sP_Numb

            '    If InStr(FileName, sP_Numb) = 0 Then

            '    FileName = sP_Numb & "_" & FileName

            '    End If

            'Else

            'sP_Numb = ""

            'End If

             

             

            'Project Number Format & SERVICE #

            Dim SPN_type As Integer

            If Mid(sP_Numb, 1, 1) = "P" Then

            sP_Numb = Mid(sP_Numb, 1, 6)

            SPN_type = 2

            ElseIf UCase(Mid(sP_Numb, 1, 3)) = "SER" Then

            sP_Numb = Mid(sP_Numb, 1, 8)

            SPN_type = 4

            Else

            SPN_type = 1

            End If

             

             

                If IsNumeric(Mid(sP_Numb, SPN_type, 5)) = True Then

                   

                    If InStr(FileName, sP_Numb) = 0 Then

                    FileName = sP_Numb & "_" & FileName

                    End If

                Else

            sP_Numb = ""

            End If

            'save loop

            For I = 1 To 2

            ' File checked Msg

            If sStatus = "FOR FAB" And FileChk <> True Then

            MsgBox "File not checked."

            End If

             

             

            boolstatus = FileSave(saveDir, FileName, sRev, FileExt(I))

            If sStatus <> "FOR FAB" Then

            Exit For

            End If

            Next I

             

             

            End Sub

             

             

             

             

            Function FileSave(DIR As String, NAME As String, REV As String, EXT As String)

            Dim SaveOption As String

            If EXT = ".EDRW" Then

            SaveOption = swEdrawingSaveAll

            Else

            SaveOption = swSaveAsOptions_Silent

            End If

            boolstatus = Application.SldWorks.ActiveDoc.Extension.SaveAs(DIR & NAME & REV & EXT, swSaveAsCurrentVersion, SaveOption, Nothing, longstatus, longwarnings)

            'Debug.Print "Error: " & longstatus & vbNewLine & "Warning: " & longwarnings

            End Function