Macro to save active drawing as PDF file into selected output folder and close drawing

Edit ArticleEdit Article

This VBA macro performs the following steps with the active SOLIDWORKS drawing:

  • Shows Browse For Folder dialog to select the output folder for the PDF file
  • Saves the active drawing as PDF file into the folder selected in the previous step. File name of the PDF will be the same as file name of the drawing
  • If the original drawing was modified, macro saves the changes
  • Closes the active SOLIDWORKS drawing document

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    Dim swDraw As SldWorks.ModelDoc2
    Set swDraw = swApp.ActiveDoc
    If swDraw Is Nothing Then
        Err.Raise vbError, "", "Open drawing"
    End If
    If swDraw.GetType() = swDocumentTypes_e.swDocDRAWING Then
        Dim outFolder As String
        outFolder = BrowseForFolder()
        If Right(outFolder, 1) = "\" Then
            outFolder = Left(outFolder, Len(outFolder) - 1)
        End If
        If outFolder <> "" Then
            Dim outFileName As String
            outFileName = GetFileNameWithoutExtension(swDraw.GetPathName()) & ".pdf"
            Dim outFilePath As String
            outFilePath = outFolder & "\" & outFileName
            Dim errs As Long
            Dim warns As Long
            If False = swDraw.Extension.SaveAs(outFilePath, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errs, warns) Then
                Err.Raise vbError, "", "Failed to export PDF to " & outFile
            End If
            If False <> swDraw.GetSaveFlag() Then
                If False = swDraw.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, errs, warns) Then
                    Err.Raise vbError, "", "Failed to save drawing"
                End If
            End If
            swApp.CloseDoc swDraw.GetTitle
        End If
        Err.Raise vbError, "", "Active document is not a drawing"
    End If
End Sub

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

Function BrowseForFolder(Optional title As String = "Select Folder") As String
    Dim shellApp As Object
    Set shellApp = CreateObject("Shell.Application")
    Dim folder As Object
    Set folder = shellApp.BrowseForFolder(0, title, 0)
    If Not folder Is Nothing Then
        BrowseForFolder = folder.Self.Path
    End If
End Function

Product of Xarial Product of Xarial