以横向和动态范围保存 PDF

Posted 2023-03-10

【中文标题】以横向和动态范围保存 PDF

【英文标题】：Save PDF in landscape and with a dynamic range

【发布时间】：2021-10-26 10:49:50

【问题描述】：

在很多帮助下，我设法制作了一个用户表单，我可以在其中选择要导出为 PDF 的工作表。之后，它会自动将创建的 PDF 作为附件发送电子邮件。

我正在使用以下代码：

Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)

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 & "_" & Sheets("Voorblad").Range("D24").Value & ".pdf"
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & xNum & ".pdf"
    xNum = 100
       
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
    End If
    xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .To = "[e-mail]"
    .CC = "[e-mail];[e-mail];[e-mail]"
    .Subject = Sheets("Voorblad").Range("B24").Value & "_" & Sheets("Voorblad").Range("D24").Value
    
    
    
    
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If DisplayEmail = False Then
        '.Send
    End If
End With
Unload Me
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

我想以横向样式和动态范围导出 PDF。 现在当我导出文件时，有时它不适合一页。

【问题讨论】：

查看Orientation、PrintArea 和FitToPagesTall 属性。

我是编码新手，你能帮我重写代码吗？

正如@Raymond Wu 想要建议的那样，您应该在导出之前正确格式化Excel表格......然后，发出数组的函数还应该检查是否有任何检查要使用的框标题是（或不是）活动工作簿中的真实工作表。

xSht.PageSetup.Orientation = xlLandscape, xSht.PageSetup.FitToPagesTall = 1 在导出工作表的行之前。如果您需要更改当前的 PrintArea，请提供类似于 xSht.PageSetup.PrintArea = "$A$1:$C$5" 的范围。到目前为止，这非常简单，我目前不在，所以如果你不打算尝试它，你必须等待某个善良的灵魂为你提供完整的解决方案。 @ThomHaasert

【参考方案1】：

@faneDuru，@Raymond Wu 我尝试了您的解决方案，我认为它有效。

我已将代码改写如下：

Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)

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 & "_" & Sheets("Voorblad").Range("D24").Value & ".pdf"
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & xNum & ".pdf"
    xNum = 100
       
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    xSht.PageSetup.Orientation = xlLandscape
    xSht.PageSetup.FitToPagesTall = 1
    xSht.PageSetup.PrintArea = "$A$1:$J$30"
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
    End If
    xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .To = "[e-mail]"
    .CC = "[e-mail];[e-mail];[e-mail]"
    .Subject = Sheets("Voorblad").Range("B24").Value & "_" & Sheets("Voorblad").Range("D24").Value
    
    
    
    
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If DisplayEmail = False Then
        '.Send
    End If
End With
Unload Me
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