Macro to Email and Attach File in a folder

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,595
Office Version
  1. 2021
Platform
  1. Windows
I have code below to attach a PDF file which is to be selected in a folder "C:\my documents"

However when activating the macro, the worbook closes and I have to re-open

It would be appreciated if someone could kindly amend my code so s to alow me to select the file to attach

Sub Email_PDF_File()
Dim File As String, strBody As String, LR As Long
TheFile = Sheets("data").Range("A42")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
File = Environ$("temp") & "\" & Sheets("Data").Range("A42") & ".xlsx"
strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
"Attached, please find PDF Journal Entries" & vbNewLine & vbNewLine & _
"Regards" & vbNewLine & vbNewLine & _
"Howard"

Set rng = Nothing


Sheets("Data").Range("Journals").Copy

Workbooks.Add
ActiveSheet.Range("a1").PasteSpecial xlPasteValues
ActiveSheet.Range("a1").PasteSpecial xlPasteFormats
ActiveSheet.Range("a1").PasteSpecial xlPasteColumnWidths

Sheets(1).Name = "Data"
LR = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
With ActiveWorkbook
With ActiveSheet.PageSetup
.PrintGridlines = True
.PrintArea = "A2:E" & LR + 10
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = "&D&T"
.CenterHeader = "Sales Journals"
.Orientation = xlLandscape
.FitToPagesWide = 1
End With

Sheets(1).Select
ActiveWindow.View = xlPageBreakPreview

.SaveAs Filename:=File, FileFormat:=51
.Close SaveChanges:=False
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)

ActiveWindow.View = xlPageBreakPreview

.To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")

.Subject = Sheets("Data").Range("a42")
.body = strBody
.Attachments.Add File


DoEvents
.Display

End With
Kill File
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub [/code]
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Hi. Give the below a try...

VBA Code:
Sub Email_PDF_File()

Dim File As String, strBody As String, LR As Long

'Looks like this was originally intended to be used in the File variable but wasn't
'Note, I added the declaration piece but can probably be discarded if not used
     Dim TheFile As String: TheFile = Sheets("data").Range("A42")

With Application
          .ScreenUpdating = False
          .DisplayAlerts = False
End With

File = Environ$("temp") & "\" & Sheets("Data").Range("A42") & ".xlsx"
strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
          "Attached, please find PDF Journal Entries" & vbNewLine & vbNewLine & _
          "Regards" & vbNewLine & vbNewLine & _
          "Howard"

Set Rng = Nothing

Sheets("Data").Range("Journals").Copy

Workbooks.Add
With ActiveSheet.Range("a1")
          .PasteSpecial xlPasteValues
          .PasteSpecial xlPasteFormats
          .PasteSpecial xlPasteColumnWidths
End With

Sheets(1).Name = "Data"
LR = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

With ActiveWorkbook
          With ActiveSheet.PageSetup
               .PrintGridlines = True
               .PrintArea = "A2:E" & LR + 10
               .PrintTitleRows = "$1:$1"
               .PrintTitleColumns = ""
               .LeftHeader = "&D&T"
               .CenterHeader = "Sales Journals"
               .Orientation = xlLandscap
               .FitToPagesWide = 1
          End With

          Sheets(1).Select
          ActiveWindow.View = xlPageBreakPreview

          .SaveAs Filename:=File, FileFormat:=51
          .Close SaveChanges:=False
End With

'set the PDF file to attach to the email using FilePicker

Dim fd As Office.FileDialog: Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim strFile As String

With fd
    .Filters.Clear
    .Filters.Add "PDF files", "*.pdf", 1
    .Title = "Choose the PDF file to attach"
    .AllowMultiSelect = False
    '.InitialFileName = "C:\my documents" 'Verify this is the correct path; will error if not
    If .Show = True Then
        strFile = .SelectedItems(1)
    End If
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)
     ActiveWindow.View = xlPageBreakPreview
        
     .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")
        
     .Subject = Sheets("Data").Range("a42")
     .body = strBody
     .attachments.Add File 'Adds the .xlsx file declared above
     .attachments.Add strFile 'Adds the PDF selected with the FilePicker
        
     DoEvents
     .Display
End With
Kill File
ActiveWindow.View = xlNormalView
With Application
          .ScreenUpdating = True
          .DisplayAlerts = True
End With
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,632
Latest member
jladair

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top