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

Для получения дополнительной информации, пожалуйста, перейдите по этой ссылке:

Как сохранить лист в виде файла PDF и отправить его по электронной почте как вложение через 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

Для получения дополнительной информации, пожалуйста, перейдите по этой ссылке:

Отправить лист Excel в виде вложения электронной почты с использованием данных листа.