'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
