VBA: Excel文件批量转化为pdf (2)

文章背景：测试仪器的数据有些会以Excel文件的形式保存，有时需要将测试数据转化为pdf格式。上篇文章（见文末的延伸阅读）通过VBA代码，采用ExportAsFixedFormat函数将excel文件转化为pdf文件，对于部分excel文件的转化效果不太好，有些谱图显示不完整，如下图所示。

经过几次尝试后发现，如果是采用另存为的方式导出为pdf文件，部分谱图会出现乱码，而通过虚拟打印机（Adobe PDF或Microsoft Print to PDF）的方式将excel文件打印输出为pdf文件，谱图则显示完整。通过使用宏记录器，发现虚拟打印机的输出过程采用的是PrintOut函数。

因此，下面以批量转化Excel文件为例，采用VBA编程，借助PrintOut函数，进行任务的实现。

在批量转化文件的按钮中添加如下的宏代码：

代码语言：javascript复制

Option Explicit

Sub ConvertFiles()

    '批量转化Excel文件为pdf
    Dim filefolder As String
    
    Dim fd As FileDialog, t As String, str As String, name As String
    
    Application.ScreenUpdating = False
    
    '获取默认路径
    ChDrive ThisWorkbook.Worksheets("Sheet1").Range("B2").Value
    ChDir ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
    
    '1 选择需要转化的文件夹路径
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fd
    
        If .Show = -1 Then
        
            t = .SelectedItems(1)
            
        Else
        
            MsgBox "未选取文件夹！"
            
            Exit Sub
            
        End If
    
    End With
    
    '2 创建储存pdf文件的空文件夹
    filefolder = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value & "pdf文件"
    
    If Not isDirectory(filefolder) Then
    
        VBA.MkDir (filefolder)
        
    Else
    
        MsgBox "默认路径的pdf文件夹已存在，请确认！"
        
        Exit Sub
    
    End If
    
    '3 批量转化excel文件
    str = Dir(t & "*.xls*")   ' 查找excel文件
    Do While Len(str) > 0
    
        Workbooks.Open (t & "" & str)
        
        name = CreateObject("Scripting.FileSystemobject").getextensionname(str)  '获取文件的扩展名
        
        ActiveWorkbook.Worksheets(1).PrintOut copies:=1, preview:=False, ActivePrinter:="Microsoft Print to PDF" _
            , PrintToFile:=True, PrToFileName:=filefolder & "" & Replace(str, name, "pdf"), IgnorePrintAreas:=False
        
        Workbooks(str).Close False
        
        str = Dir()
        
    Loop
    
    MsgBox "Done!"
    
    Application.ScreenUpdating = True
    
    Exit Sub

End Sub

Function isDirectory(pathName As String) As Boolean

    '用于判断文件夹是否存在
    
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    isDirectory = fso.FolderExists(pathName)

End Function

运行效果展示http://mpvideo.qpic.cn/0bf2oiacoaaatmanhciesrqva4wde5zaajya.f10002.mp4?dis_k=6dfbb616ed245b6194e5e38e49636a47&dis_t=1663655784&vid=wxv_1981767069717135363&format_id=10002&support_redirect=0&mmversion=false

参考资料：

[1] Sheets.PrintOut method (Excel)（https://docs.microsoft.com/en-us/office/vba/api/excel.sheets.printout）

[2] Converting a worksheet to PDF using VBA PrintOut method (https://stackoverflow.com/questions/43437576/converting-a-worksheet-to-pdf-using-vba-printout-method)