Excel VBA导出工作表为PDF时如何实现单张A4页面自适应

解决方法 #

你只需要在导出PDF的代码前添加页面缩放适配的配置即可，核心逻辑是强制指定导出范围适配单张A4纸张的宽高。

修改后的完整代码 #

首先是CommandButton1的点击事件代码，新增的页面配置部分已标注：

Option Explicit
    
Private Sub CommandButton1_Click()
  Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
  Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
  Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
  ' 可选：定义变量存储原有页面设置，避免修改工作表原有配置
  Dim oldPaperSize, oldZoom, oldFitW, oldFitT, oldPrintArea
     
     xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
    
     For I = 0 To UBound(xArrShetts)
        On Error Resume Next
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        If xSht.Name <> xArrShetts(I) Then
            MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
        Exit Sub
        End If
     Next
    
     Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
     If xFileDlg.Show = True Then
        xFolder = xFileDlg.SelectedItems(1)
     Else
        MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
        Exit Sub
     End If
     'Check if file already exist
     xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
     vbYesNo + vbQuestion, "File Exists")
     If xYesorNo <> vbYes Then Exit Sub
     For I = 0 To UBound(xArrShetts)
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        
        xStr = xFolder & "\" & xSht.Name & ".pdf"
        xNum = 1
        While Not (Dir(xStr, vbDirectory) = vbNullString)
            xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
            xNum = xNum + 1
        Wend
        Set xUsedRng = xSht.UsedRange
        If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
            Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)   'determine the last cell in A:A
            Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))  'create the range to be exported as pdf
            
            ' ------------------- 新增页面适配配置开始 -------------------
            ' 可选：备份原有页面配置
            With xSht.PageSetup
                oldPaperSize = .PaperSize
                oldZoom = .Zoom
                oldFitW = .FitToPagesWide
                oldFitT = .FitToPagesTall
                oldPrintArea = .PrintArea
            End With
            
            ' 设置适配单张A4
            With xSht.PageSetup
                .PaperSize = xlPaperA4 ' 指定纸张为A4
                .Zoom = False ' 必须关闭自定义缩放才能启用按页数适配
                .FitToPagesWide = 1 ' 宽度适配1页
                .FitToPagesTall = 1 ' 高度适配1页
                .PrintArea = rngExp.Address ' 仅打印目标范围
            End With
            ' ------------------- 新增页面适配配置结束 -------------------
            
            rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard 'export the range, not the sheet
            
            ' 可选：恢复工作表原有页面配置
            With xSht.PageSetup
                .PaperSize = oldPaperSize
                .Zoom = oldZoom
                .FitToPagesWide = oldFitW
                .FitToPagesTall = oldFitT
                .PrintArea = oldPrintArea
            End With
        End If
        xArrShetts(I) = xStr
     Next
    
     'Create Outlook email
     Set xOutlookObj = CreateObject("Outlook.Application")
     Set xEmailObj = xOutlookObj.CreateItem(0)
     With xEmailObj
        .Display
        .To = "Administratie@holwerda.nl"
        .cc = "Gerben@holwerda.nl"
        .Subject = "????"
        For I = 0 To UBound(xArrShetts)
            .Attachments.Add xArrShetts(I)
        Next
        If .DisplayEmail = False Then
            '.Send
        End If
     End With
End Sub

另外两个辅助函数不需要修改，保持原有代码即可：

Private Function sheetsArr(uF As UserForm) As Variant
  Dim c As MSForms.Control, strCBX As String, arrSh
      For Each c In uF.Controls
            If TypeOf c Is MSForms.CheckBox Then
                If c.Value = True Then strCBX = strCBX & "," & c.Caption
            End If
      Next
      sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function

Private Sub CommandButton2_Click()
    Unload Me
End Sub

配置说明 #

• 如果你不需要保留工作表原有页面设置，可以删掉备份和恢复原有配置的代码，仅保留中间的A4适配配置即可
• 如果只需要适配宽度不需要适配高度，可将.FitToPagesTall = 1改为.FitToPagesTall = False，反之同理

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