'CADHERO.COM
'INSPIRED BY SW API SAMPLE SNIPPETS & WRITTEN BY AMEN JLILI
'[email protected]
' Updated by Deepak Gupta (Boxer's SOLIDWORKS Blog, India) http://gupta9665.com/
' Please back up your data before use and USE AT OWN RISK
' 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. If any portion of
' this code is used in other works, credit to the authors must be placed in
' that work within a user viewable location (e.g., macro header). 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!
'當前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
