Macro to Email and Attach File in a folder

[howard]

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]

 

[breynolds0431]

Hi. Give the below a try...

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

 

[howard]

Many Thanks for the help. Your code works 100%