VBA 将 Excel 工作表作为 PDF 和 Excel 文件发送

Question

我找到了一些编码，可以将我的工作表以 pdf 格式通过电子邮件发送（我忘记了它在哪个网站上，所以如果你在这里创建它，谢谢！）。有人问我是否可以在电子邮件中包含该文件的 excel 版本以及当前的 pdf 文件（有些人需要它来复制并粘贴到其他报告中）。以下是我当前的 VBA。我不知道如何将当前工作表作为 excel 文件作为附件附加到电子邮件中。

感谢您的帮助！

Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  ' Not sure for what the Title is
  Title = Range("A1")

  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = Format(Now(), "MM-dd-yyyy") & " File Name" & ".pdf"

  ' Export activesheet as PDF
  With ActiveSheet
    .PageSetup.PaperSize = xlPaperLegal
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)

' Prepare e-mail
.Subject = "Email Name " & Format(Now(), "MM-dd-yyyy")
.To = "xxx" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "All," & vbLf & vbLf _
      & "xxx." & vbLf & vbLf _
      & "Regards," & vbLf _
      & Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile

' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
  MsgBox "E-mail was not sent", vbExclamation
Else
  MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

  End With

  ' Delete PDF file
  Kill PdfFile

  ' Release the memory of object variable
  Set OutlApp = Nothing



End Sub

Answer 1

您可以使用以下代码将工作表保存为 pdf 文件并将其作为附件通过电子邮件发送：

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
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
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

更多信息，请参考此链接：

How To Save A Worksheet As PDF File And Email It As An Attachment Through Outlook?

如果要将当前工作表作为excel文件作为附件附加到电子邮件中，请参考以下代码：

Option Explicit 

Sub EmailandSaveCellValue() 

     'Variable declaration
    Dim oApp As Object, _ 
    oMail As Object, _ 
    WB As Workbook, _ 
    FileName As String, MailSub As String, MailTxt As String 

     '*************************************************  ********
     'Set email details; Comment out if not required
    Const MailTo = "some1@someone.com" 
    Const MailCC = "some2@someone.com" 
    Const MailBCC = "some3@someone.com" 
    MailSub = "Please review " & Range("Subject") 
    MailTxt = "I have attached " & Range("Subject") 
     '*************************************************  ********

     'Turns off screen updating
    Application.ScreenUpdating = False 

     'Makes a copy of the active sheet and save it to
     'a temporary file
    ActiveSheet.Copy 
    Set WB = ActiveWorkbook 
    FileName = Range("Subject") & " Text.xls" 
    On Error Resume Next 
    Kill "C:\" & FileName 
    On Error Goto 0 
    WB.SaveAs FileName:="C:\" & FileName 

     'Creates and shows the outlook mail item
    Set oApp = CreateObject("Outlook.Application") 
    Set oMail = oApp.CreateItem(0) 
    With oMail 
        .To = MailTo 
        .Cc = MailCC 
        .Bcc = MailBCC 
        .Subject = MailSub 
        .Body = MailTxt 
        .Attachments.Add WB.FullName 
        .Display 
    End With 

     'Deletes the temporary file
    WB.ChangeFileAccess Mode:=xlReadOnly 
    Kill WB.FullName 
    WB.Close SaveChanges:=False 

     'Restores screen updating and release Outlook
    Application.ScreenUpdating = True 
    Set oMail = Nothing 
    Set oApp = Nothing 
End Sub

更多信息，请参考此链接：

Send Excel sheet as email attachment using worksheet data.