Блог

Главная - Вопросы по программированию - Excel VBA — Сохранение PDF-файлов в одно электронное письмо вместо создания нескольких отдельных писем

Excel VBA — Сохранение PDF-файлов в одно электронное письмо вместо создания нескольких отдельных писем

#excel #vba #pdf

Вопрос:

Я пытаюсь сохранить несколько PDF-файлов в одно вложение электронной почты. Однако приведенный ниже код создает электронное письмо в формате PDF. Вместо этого я хотел бы вложить все свои PDF-файлы в одно электронное письмо.

Электронная почта()

 Dim WksAct As Worksheet
Dim LastRow As Integer, i As Integer
Dim MySheet As String, myFile As String
Dim OutlookApp As Object, MItem As Object

Set WksAct = ThisWorkbook.Sheets("Activity")
LastRow = WksAct.Range("A" amp; Rows.Count).End(xlUp).Row

For i = 1 To LastRow
    
    If WksAct.Range("B" amp; i).Value < 0 Then
        MySheet = WksAct.Range("A" amp; i).Value
        myFile = ThisWorkbook.Path amp; "" amp; MySheet amp; ".pdf"
        Sheets(MySheet).ExportAsFixedFormat _
                                            Type:=xlTypePDF, _
                                            Filename:=myFile, _
                                            Quality:=xlQualityStandard, _
                                            IncludeDocProperties:=True, _
                                            IgnorePrintAreas:=False, _
                                            OpenAfterPublish:=False
        
        Set OutlookApp = CreateObject("Outlook.Application")
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = "test@mail.com"
            .Subject = "my Subject - To be adapted!"
            .Body = " Please find... "
            .Attachments.Add myFile
            .Display
            ' .Send
        End With
    End If
    
Next i

Конец Суб

Комментарии:

1. Непонятно, о чем вы спрашиваете. В соответствии с вашим кодом это выглядит так, как будто вы создаете новый pdf-файл и создаете новое электронное письмо ДЛЯ КАЖДОЙ ИТЕРАЦИИ ЦИКЛА . Вопрос: Это действительно то, что вы хотите сделать? ПРЕДЛОЖЕНИЕ: Может быть, вы хотите 1) переместить «создать электронную почту» ( Create MItem ) НАД циклом, 2) продолжить создание PDF-файлов внутри цикла, но 3) просто добавьте (Mitem. Вложения. Добавляйте` каждую итерацию. Попробуйте, посмотрите, действительно ли это то, что вы ищете.

2. Вероятно, следует переместить все из Set OutlookApp = CreateObject("Outlook.Application") в End With , кроме как за .Attachments.Add myFile пределы цикла. И внести поправки в MItem.Attachments.Add myFile

Ответ №1:

Предложения

  1. При работе со строками в Excel используйте Long и не Integer используйте . Вы можете получить ошибку переполнения.
  2. Создайте объект Outlook один раз вместо того, чтобы делать это в цикле.

Код

 Option Explicit

Sub Mail()
    Dim WksAct As Worksheet
    Dim LastRow As Long, i As Integer
    Dim MySheet As String, myFile As String
    Dim OutlookApp As Object, MItem As Object
    
    '~~> Work with Outlook Object
    Set OutlookApp = CreateObject("Outlook.Application")
    '~~> Create the email
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = "test@mail.com"
        .Subject = "my Subject - To be adapted!"
        .Body = " Please find... "
    End With
    
    Set WksAct = ThisWorkbook.Sheets("Activity")
    
    With WksAct
        LastRow = .Range("A" amp; .Rows.Count).End(xlUp).Row

        For i = 1 To LastRow
            If .Range("B" amp; i).Value2 < 0 Then
                MySheet = .Range("A" amp; i).Value2
                
                myFile = ThisWorkbook.Path amp; "" amp; MySheet amp; ".pdf"
                
                Sheets(MySheet).ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=myFile, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
                
                '~~> Give time for the save to happen
                DoEvents
                
                '~~> Attach the file
                MItem.Attachments.Add myFile
            End If
        Next i
    End With
    
    '~~> Show the email
    MItem.Display
End Sub

Альтернатива

Альтернативой было бы создать электронное письмо в конце и добавить все PDF-файлы за один раз. Например:

 Option Explicit

Sub Mail()
    Dim WksAct As Worksheet
    Dim LastRow As Long, i As Integer
    Dim MySheet As String, myFile As String
    Dim OutlookApp As Object, MItem As Object
           
    Set WksAct = ThisWorkbook.Sheets("Activity")
    
    With WksAct
        LastRow = .Range("A" amp; .Rows.Count).End(xlUp).Row

        For i = 1 To LastRow
            If .Range("B" amp; i).Value2 < 0 Then
                MySheet = .Range("A" amp; i).Value2
                
                myFile = ThisWorkbook.Path amp; "" amp; MySheet amp; ".pdf"
                
                Sheets(MySheet).ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=myFile, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
                
                '~~> Give time for the save to happen
                DoEvents
            End If
        Next i
    End With
    
    Dim StrFile As String
    
    '~~> Check if any pdfs were created and then
    '~~> create the email
    StrFile = Dir(ThisWorkbook.Path amp; "*.pdf")
    If StrFile <> "" Then
        '~~> Work with Outlook Object
        Set OutlookApp = CreateObject("Outlook.Application")
        '~~> Create the email
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = "test@mail.com"
            .Subject = "my Subject - To be adapted!"
            .Body = " Please find... "
        
            '~~> Loop through all pdf and then add them
            Do While Len(StrFile) > 0
                MItem.Attachments.Add ThisWorkbook.Path amp; "" amp; StrFile
                StrFile = Dir
            Loop

            '~~> Show the email
            .Display
        End If
    End If
End Sub
Метки: