批量转换excel文件为pdf的VBA脚本
编程技术 / houtizong 发布于 3年前 89
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 IfEnd 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'<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, "[email protected]", "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 IfEnd Sub
上一篇：关于异常的总结
请勿发布不友善或者负能量的内容。与人为善，比聪明更重要！
技术博客集 - 网站简介：
前后端技术：
后端基于Hyperf2.1框架开发,前端使用Bootstrap可视化布局系统生成
网站主要作用：
1.编程技术分享及讨论交流，内置聊天系统;
2.测试交流框架问题，比如：Hyperf、Laravel、TP、beego;
3.本站数据是基于大数据采集等爬虫技术为基础助力分享知识，如有侵权请发邮件到站长邮箱，站长会尽快处理;
4.站长邮箱：[email protected];
文章归档
文章标签
友情链接
