SolidWorks 工程图 转PDF的宏(VBA 代码)

'当前SolidWorks工程图文件转PDF,可含多页的工程图
' ------------------------------------------------------------------------------
'****************************************
'---此模块演示一个可以延时关闭的消息框---API函数 未公开的
'****************************************
#If Win64 Then '64位
    Private Declare PtrSafe Function MsgBoxTimeout _
        Lib "user32" _
        Alias "MessageBoxTimeoutA" ( _
            ByVal hWnd As LongPtr, _
            ByVal lpText As String, _
            ByVal lpCaption As String, _
            ByVal wType As VbMsgBoxStyle, _
            ByVal wlange As Long, _
            ByVal dwTimeout As Long) _
    As Long
#Else
    Private Declare Function MsgBoxTimeout _
        Lib "user32" _
        Alias "MessageBoxTimeoutA" ( _
            ByVal hwnd As Long, _
            ByVal lpText As String, _
            ByVal lpCaption As String, _
            ByVal wType As VbMsgBoxStyle, _
            ByVal wlange As Long, _
            ByVal dwTimeout As Long) _
    As Long
#End If

'ShellExecute API函数
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hWnd As Long, _
  ByVal lpOperation As String, ByVal lpFile As String, _
  ByVal lpParameters As String, ByVal lpDirectory As String, _
  ByVal nShowCmd As Long) As Long

  
Option Explicit
  
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim swExportPDFData     As SldWorks.ExportPdfData
    Dim boolstatus          As Boolean
    Dim filename            As String
    Dim lErrors             As Long
    Dim lWarnings           As Long
    Dim strSheetName()     As String
    Dim varSheetName        As Variant
    Dim swSheet             As SldWorks.Sheet
    Dim value               As String
    Dim resolvedValOut      As String
    Dim swView              As SldWorks.View
    Dim swPart              As SldWorks.ModelDoc2
    Dim swCustProp          As CustomPropertyManager
    Dim nSheet              As Variant
    Dim pdfFileName         As String   'pdf文件名
    Dim swFrame As Object
    Dim ProgressBar As Object '进度条
Sub main()
  
    Set swApp = Application.SldWorks
  
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
    MsgBox "无活动文档，请打开一个SW文件！", vbExclamation
    
    Exit Sub '退出Sub
    End If
    
    If swModel.GetType <> SwConst.swDocumentTypes_e.swDocDRAWING Then
    MsgBox ("当前活动文档不是2D工程图文件!")
    Exit Sub
    End If
    
    Set swFrame = swApp.Frame
    swApp.GetUserProgressBar ProgressBar '进度条
    
    filename = swModel.GetPathName
    
    If swModel.GetPathName = "" Then
     MsgBox ("请先保存文件！")
    Exit Sub
    End If
    
    Set swModelDocExt = swModel.Extension
    Set swExportPDFData = swApp.GetExportFileData(1)
    
               
    ReDim strSheetName(0)
    For Each nSheet In swModel.GetSheetNames
            strSheetName(UBound(strSheetName)) = nSheet
            ReDim Preserve strSheetName(UBound(strSheetName) + 1)
    Next nSheet
    
    varSheetName = strSheetName
    
    
    Set swSheet = swModel.GetCurrentSheet
    Set swView = swModel.GetFirstView
    Set swView = swView.GetNextView
    Set swPart = swView.ReferencedDocument
    Set swCustProp = swPart.Extension.CustomPropertyManager("")
    swCustProp.Get2 "H.B. Carbide Part#", value, resolvedValOut ' change property name here
            
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
           
    pdfFileName = Left$(filename, InStrRev(filename, ".") - 1) + ".PDF"
       
    If fso.FileExists(pdfFileName) Then
    
     Dim xRet1 As Long
    xRet1 = MsgBoxTimeout(0, "是否覆盖文件 " & pdfFileName, "覆盖文件 (5秒后自动覆盖)", vbYesNo + vbExclamation, 1, 5000)
    Select Case xRet1
    Case 32000
        Debug.Print "超时自动关闭"
        
    Case vbYes
      
        Debug.Print "选择""是""按钮"
    Case vbNo
        Debug.Print "选择""否""按钮"
        Exit Sub '退出
    End Select
   
   
    End If
          
    If swExportPDFData Is Nothing Then MsgBox "swExportPDFData Nothing"
    boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, varSheetName)
    swExportPDFData.ViewPdfAfterSaving = False
    
    ProgressBar.Start 0, 100, "正在保存文件..."
    ProgressBar.UpdateProgress (50)
    boolstatus = swModelDocExt.SaveAs(pdfFileName, 0, 0, swExportPDFData, lErrors, lWarnings)
    'MsgBox pdfFileName
    ProgressBar.UpdateProgress (100)
    swFrame.SetStatusBarText ("另存为PDF文件OK：" & pdfFileName)
    Dim Result As Long
    
    
    
     Dim xRet2 As Long
    xRet2 = MsgBoxTimeout(0, "另存为PDF OK, 是否现在打开" & pdfFileName, "是否打开PDF (5秒后自动打开PDF)", vbYesNo + vbQuestion, 1, 5000)
    Select Case xRet2
    Case 32000
        Debug.Print "超时自动关闭"
        Result = ShellExecute(0&, vbNullString, pdfFileName, _
        vbNullString, vbNullString, vbNormalFocus)
        If Result < 32 Then MsgBox "Error 打开文件失败"
    Case vbYes
        Result = ShellExecute(0&, vbNullString, pdfFileName, _
        vbNullString, vbNullString, vbNormalFocus)
    If Result < 32 Then MsgBox "Error 打开文件失败"
    
    Case vbNo
        Debug.Print "选择""否""按钮"
    End Select
    
    ProgressBar.End
End Sub