批量转换excel⽂件为pdf的VBA脚本
Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
'Test to see if the Microsoft Create/Send add-in is installed.
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog, exit the function.
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False then test to see if the PDF
'already exists in the folder and exit the function if it does.
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
'Now export the PDF file.
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False
On Error GoTo 0
'If the export is successful, return the file name.
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End If
End Function
Function DigIn(sPath As String)
Dim FS, f, f1, fc, s
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFolder(sPath)
Set fc = f.Files
For Each f1 In fc
ExtName = GetExtName(f1.Path)
If ExtName = "xlsx" Then
RDB_Workbook_To_PDF (f1.Path)
End If
Next
For Each subfolder In f.SubFolders
s = s & subfolder.Path
DigIn (subfolder.Path)
Next
End Function
Function GetExtName(ScanString As String) As String
'*******************************************************
'<DESC>    Retrieves File Extension Name from full
'      directory path</DESC>
'<RETURN>  File Extension Only
'          </RETURN>
'<ACCESS>  Public
excel最强教科书完全版pdf'<ARGS>    FullPath:
'          Full Filepath incl. Filename
'              </ARGS>
'<USAGE>    If GetExtName("c:\autoexec.bat")
'              </USAGE>
'*******************************************************
Dim intPos As String
Dim intPosSave As String
If InStr(ScanString, ".") = 0 Then
GetExtName = ""
Exit Function
End If
intPos = 1
Do
intPos = InStr(intPos, ScanString, ".")
If intPos = 0 Then
Exit Do
Else
intPos = intPos + 1
intPosSave = intPos - 1
End If
Loop
GetExtName = Trim$(Mid$(ScanString, intPosSave + 1))
End Function
Sub RDB_Convert_Files_To_PDF()
Dim sStartPath As String
Dim sWhat As String
sStartPath = "D:/workspace/clothes-report/data/fankui/output" 'Where?
sWhat = "test.log" 'What?
result = DigIn(sStartPath) 'First step
End Sub
Sub RDB_Workbook_To_PDF(fPath As String)
Dim FileName As String
'Call the function with the correct arguments.
Workbooks.Open fPath
FileName = RDB_Create_PDF(ActiveWorkbook, Replace(fPath, ".xlsx", "") & ".pdf", True, True)
ActiveWorkbook.Close SaveChanges:=False
'For a fixed file name and to overwrite the file each time you run the macro, use the following statement.    'RDB_Create_PDF(ActiveWorkbook, "C:\Users\Ron\Test\YourPdfFile.pdf", True, True)
If FileName <> "" Then
'Uncomment the following statement if you want to send the PDF by mail.
'RDB_Mail_PDF_Outlook FileName, "ron@debruin.nl", "This is the subject", _
"See the attached PDF file with the last figures" _
& vbNewLine & vbNewLine & "Regards Ron de bruin", False
Else
MsgBox "It is not possible to create the PDF; possible reasons:" & vbNewLine & _              "Microsoft Add-in is not installed" & vbNewLine & _
"You canceled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exists."
End If
End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。