如何通过VBA实现CSV文件打印效果与XLSX一致（含现有脚本）

我需要实现CSV文件打印时呈现和XLSX一致的格式，当前CSV打印效果不符合预期（参考Current CSV图），期望达到Desired CSV图的效果。现有两段VBA脚本：

• Outlook会话脚本：自动检测主题包含"People on site"的邮件，提取其中的CSV附件
• Module1脚本：实现CSV文件在两台打印机（\\PRINTSRV01\PEY01、\\PRINTSRV01\PEY05）切换打印

现有Outlook会话脚本 #

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objNamespace As Outlook.NameSpace
    Dim objMail As Object ' 用Object捕获所有类型元素
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.attachment
    Dim entryID As String
    Dim entryIDs() As String
    Dim i As Long
    Dim tempFolder As String
    Dim filePath As String
    
    ' 临时文件夹路径
    tempFolder = "C:\temp\"
    
    ' 确保文件夹存在
    If Dir(tempFolder, vbDirectory) = "" Then
        MkDir tempFolder
    End If
    
    ' 获取Outlook命名空间
    Set objNamespace = Application.GetNamespace("MAPI")
    
    ' 分割EntryIDCollection，处理多邮件接收情况
    entryIDs = Split(EntryIDCollection, ",")
    
    ' 遍历每一封收到的邮件
    For i = LBound(entryIDs) To UBound(entryIDs)
        entryID = entryIDs(i)
        
        On Error Resume Next
        ' 尝试获取邮件项
        Set objMail = objNamespace.GetItemFromID(entryID)
        On Error GoTo 0
        
        ' 检查对象是否成功获取
        If Not objMail Is Nothing Then
            ' 确认是MailItem类型
            If TypeOf objMail Is Outlook.mailItem Then
                ' 检查邮件主题是否包含指定文本（用InStr提升灵活性）
                If InStr(1, Trim(LCase(objMail.Subject)), "People on site", vbTextCompare) > 0 Then
                    
                    ' 获取附件集合
                    Set objAttachments = objMail.Attachments
                    
                    ' 遍历所有附件
                    For Each objAttachment In objAttachments
                        ' 检查是否为CSV文件
                        If LCase(Right(objAttachment.FileName, 3)) = "csv" Then
                            ' 临时文件路径
                            filePath = tempFolder & objAttachment.FileName
                            
                            ' 保存附件到临时文件夹
                            objAttachment.SaveAsFile filePath
                            
                            ' 调用打印函数（确保该函数已定义）
                            PrintCSVOnMultiplePrinters filePath
                            
                            ' 打印完成后删除临时文件
                            Kill filePath
                        End If
                    Next objAttachment
                End If
            End If
        Else
            Debug.Print "错误：无法获取ID为 " & entryID & " 的元素"
        End If
    Next i
    
    ' 释放对象
    Set objNamespace = Nothing
    Set objMail = Nothing
    Set objAttachments = Nothing
End Sub

现有Module1脚本 #

Declare PtrSafe Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" (ByVal printerName As String) As Long


Sub PrintCSVOnMultiplePrinters(filePath As String)
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim currentPrinter As String

    ' 创建Excel应用实例
    Set xlApp = CreateObject("Excel.Application")

    ' 打开CSV文件（只读模式）
    Set xlBook = xlApp.Workbooks.Open(filePath, False, True)
    
    ' 选择第一个工作表
    Set xlSheet = xlBook.Sheets(1)
    
    ' 保存当前默认打印机
    currentPrinter = xlApp.ActivePrinter
    
    ' 切换到第一台打印机并打印
    Call SetDefaultPrinter("\\PRINTSRV01\PEY01")
    xlSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
    
    ' 切换到第二台打印机并打印
    Call SetDefaultPrinter("\\PRINTSRV01\PEY05")
    xlSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
    
    ' 恢复原默认打印机
    Call SetDefaultPrinter(currentPrinter)
    
    ' 关闭文件不保存
    xlBook.Close False
    xlApp.Quit
    
    ' 释放内存
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

优化后的Module1脚本（实现CSV打印格式匹配XLSX） #

Declare PtrSafe Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" (ByVal printerName As String) As Long


Sub PrintCSVOnMultiplePrinters(filePath As String)
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim currentPrinter As String
    Dim usedRange As Object

    ' 创建Excel应用实例
    Set xlApp = CreateObject("Excel.Application")
    ' 可选：如需查看Excel操作过程，将False改为True
    ' xlApp.Visible = True

    ' 打开CSV文件（指定逗号为分隔符，确保解析正确）
    Set xlBook = xlApp.Workbooks.Open( _
        Filename:=filePath, _
        Format:=2, ' 2代表逗号分隔
        ReadOnly:=True)
    
    ' 选择第一个工作表
    Set xlSheet = xlBook.Sheets(1)
    Set usedRange = xlSheet.UsedRange

    ' ---------- 设置打印格式，匹配XLSX效果 ----------
    ' 1. 自动调整列宽
    usedRange.Columns.AutoFit
    
    ' 2. 设置字体（按实际XLSX格式调整，示例为Calibri 10号）
    usedRange.Font.Name = "Calibri"
    usedRange.Font.Size = 10
    
    ' 3. 设置单元格对齐方式（水平+垂直居中，按需调整）
    usedRange.HorizontalAlignment = -4108 ' xlCenter
    usedRange.VerticalAlignment = -4108 ' xlCenter
    
    ' 4. 设置打印区域为已用数据范围
    xlSheet.PageSetup.PrintArea = usedRange.Address
    
    ' 5. 适配页面宽度，避免内容截断
    xlSheet.PageSetup.FitToPagesWide = 1
    xlSheet.PageSetup.FitToPagesTall = False
    
    ' 6. 设置页面方向（纵向：-4163；横向：-4137，按XLSX调整）
    xlSheet.PageSetup.Orientation = -4163 ' xlPortrait
    
    ' 7. 打印网格线（按XLSX是否显示调整）
    xlSheet.PageSetup.PrintGridlines = True
    
    ' ---------- 原有打印逻辑保持不变 ----------
    ' 保存当前默认打印机
    currentPrinter = xlApp.ActivePrinter
    
    ' 切换到第一台打印机并打印
    Call SetDefaultPrinter("\\PRINTSRV01\PEY01")
    xlSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
    
    ' 切换到第二台打印机并打印
    Call SetDefaultPrinter("\\PRINTSRV01\PEY05")
    xlSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
    
    ' 恢复原默认打印机
    Call SetDefaultPrinter(currentPrinter)
    
    ' 关闭文件不保存
    xlBook.Close False
    xlApp.Quit
    
    ' 释放内存
    Set usedRange = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

优化说明 #

• 打开CSV时指定Format:=2，确保逗号分隔符被正确解析，避免列错位
• 添加自动列宽调整、字体设置、单元格对齐等格式配置，匹配XLSX视觉效果
• 设置FitToPagesWide = 1确保内容适配页面宽度，防止截断
• 可根据实际XLSX的格式，调整字体、对齐方式、页面方向、网格线等参数
• 保留原有多打印机切换逻辑，不改变核心功能

内容的提问来源于stack exchange，提问作者Gamix