Need my Emailing Macro to attach files

[Pobek]

Hi guys,

I have this code that automatically sends emails from my excel model on outlook. Can anyone suggest a straightforward (or otherwise) tweak that will enable it to send attachments??

Code:

Sub SendRunRequest()

Dim Msg As String
Dim olApp As Object
Dim olEmail As Object
Dim SendAt As String
Dim SendTo As String
Dim Sendcc As String
Dim Subj As String

Dim resp As Long

Calculate




recipient = Range("f27").Value
ReqCC = Range("f28").Value
subje = Range("f29").Value
mes = Range("f31").Value


SendTo = recipient
Sendcc = ReqCC
Subj = subje
Msg = mes

'SendAt = "10/19/2008 12:30am" 'Date-Time must be in this format

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
olApp.Session.Logon

Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
' .DeferredDeliveryTime = SendAt
.To = SendTo
.cc = Sendcc
.Subject = Subj
.Body = Msg

resp = MsgBox(Prompt:="Are you sure you want to send off this email?", _
Buttons:=vbYesNo, Title:="Warning")

If resp = vbYes Then
.Send
MsgBox "Email sent!"
End If

End With

olApp.Session.Logoff

Set olApp = Nothing
Set olEmail = Nothing


End Sub

 

[mrshl9898]

Where you have

.Body = Msg
.Attachments.Add (ActiveWorkbook.FullName or file location and book name.xlsx etc.)

 

[Pobek]

Where you have

.Body = Msg
.Attachments.Add (ActiveWorkbook.FullName or file location and book name.xlsx etc.)

Thanks for that but its saying "object does not support this property or object" in the error and falling over at the .attachement.add line:

even tried another .add with full hardcoded directory path and still nothing ... any thoughts?

Dim Msg As String
Dim olApp As Object
Dim olEmail As Object
Dim SendAt As String
Dim SendTo As String
Dim Sendcc As String
Dim Subj As String

Dim resp As Long

Calculate




recipient = Range("f27").Value
ReqCC = Range("f28").Value
subje = Range("f29").Value
mes = Range("f31").Value
attache = Range("attache").Value
attachepath = Range("attachePath").Value
attachement = attachepath & "" & attachepath
SendTo = recipient
Sendcc = ReqCC
Subj = subje
Msg = mes

'SendAt = "10/19/2008 12:30am" 'Date-Time must be in this format

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
olApp.Session.Logon

Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
' .DeferredDeliveryTime = SendAt
.To = SendTo
.cc = Sendcc
.Subject = Subj
.Body = Msg
'.attachement.Add (attchmnt)
.attachement.Add ("C:\Users\POBEK\Documents\Professional\POBEK\POBEK Consulting\Buss\Industry\Payroll\Staff 1 Dated 6 - 2017.pdf")

 

[Pobek]

Forgot to say i also dimed the 'attache', 'attachepath' and 'attchmnt'

 

[mrshl9898]

Looks like a typo? Unless this is a different language.

Apart from that, it looks identical to what I use.

One of these SHOULD work

.attachments.Add (attachement)
.attachments.Add ("C:\Users\POBEK\Documents\Professional\POBEK\POBEK Consulting\Buss\Industry\Payroll\Staff 1 Dated 6 - 2017.pdf")
.attachments.Add "C:\Users\POBEK\Documents\Professional\POBEK\POBEK Consulting\Buss\Industry\Payroll\Staff 1 Dated 6 - 2017.pdf"

 

[Pobek]

Nope not working. What precisely do you have that has worked?

 

[mrshl9898]

Here's my full code. There's a while before it gets to the email.

I have used your other examples before as well though. FYI i'm using Excel 2013

Sub exportdaily()


Application.DisplayAlerts = False
Application.ScreenUpdating = False




Dim rng As Range
Dim Rng1 As String 'reporting day name
Dim rng2 As String 'name of reporting day in daily tab
Dim Rng3 As String 'month year\ file location
Dim Rng4 As String
Dim rng6 As Range
Dim rng10 As String
Dim rng8 As String




Dim FName As String
Dim FPath As String
Dim OutlookApp As Object, OutlookMail As Object
Dim EmailSubject As String, EmailSignature As String
Dim Email_To As String, Email_CC As String, Email_BCC As String


Rng1 = Worksheets("Dashboard").Range("A2")
Rng3 = Worksheets("Dashboard").Range("A5")
rng8 = Worksheets("Dashboard").Range("A12")




If Rng1 = "Mon" Then
    Worksheets(Array("Mon", "Data List", "Week To Date")).Select
    Worksheets(Array("Mon", "Data List", "Week To Date")).Copy
End If


If Rng1 = "Tues" Then
    Worksheets(Array("Mon", "Tues", "Data List", "Week To Date")).Select
    Worksheets(Array("Mon", "Tues", "Data List", "Week To Date")).Copy
End If


If Rng1 = "Wed" Then
    Worksheets(Array("Mon", "Tues", "Wed", "Data List", "Week To Date")).Select
    Worksheets(Array("Mon", "Tues", "Wed", "Data List", "Week To Date")).Copy
End If


If Rng1 = "Thurs" Then
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Data List", "Week To Date")).Select
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Data List", "Week To Date")).Copy
End If


If Rng1 = "Fri" Then
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Fri", "Data List", "Week To Date")).Select
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Fri", "Data List", "Week To Date")).Copy
End If




    Worksheets(Rng1).Select
    
rng2 = Worksheets(Rng1).Range("B2")


If Rng1 = "Mon" Then
    Worksheets(Array("Mon")).Select
    Rows("28:52").Select
    Selection.Delete Shift:=xlUp
    Worksheets(Array("Mon", "Data List", "Week To Date")).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Worksheets("Week To Date").Select
End If


If Rng1 = "Tues" Then
    Worksheets(Array("Mon", "Tues")).Select
    Rows("28:52").Select
    Selection.Delete Shift:=xlUp
    Worksheets(Array("Mon", "Tues", "Data List", "Week To Date")).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Worksheets("Week To Date").Select
End If


If Rng1 = "Wed" Then
    Worksheets(Array("Mon", "Tues", "Wed")).Select
    Rows("28:52").Select
    Selection.Delete Shift:=xlUp
    Worksheets(Array("Mon", "Tues", "Wed", "Data List", "Week To Date")).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Worksheets("Week To Date").Select
End If


If Rng1 = "Thurs" Then
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs")).Select
    Rows("28:52").Select
    Selection.Delete Shift:=xlUp
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Data List", "Week To Date")).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Worksheets("Week To Date").Select
End If


If Rng1 = "Fri" Then
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Fri")).Select
    Rows("28:52").Select
    Selection.Delete Shift:=xlUp
    Worksheets(Array("Mon", "Tues", "Wed", "Thurs", "Fri", "Data List", "Week To Date")).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Worksheets("Week To Date").Select
End If






    FPath = "\\epping\public$\smithy\Weekly Reports\DPM\2017\" & Rng3
    ActiveWorkbook.SaveAs FPath & rng8 & ".xlsx", FileFormat:=51
    
    Set rng = Sheets(Rng1).Range("B2:G53").SpecialCells(xlCellTypeVisible)




    
    'email
    EmailSubject = "DPM " & rng8
    DisplayEmail = True
    Email_To = "Maintrak AU Daily KPI <MaintrakAUDailyKPI@mainfreight.co.nz>"
    Email_CC = "Andrew Marshall <andrew.marshall@mainfreight.com.au>; Andrew Smith (MFD Australia) <andrew.smith@mainfreight.com.au>; Nikki Lindsay <nikki.lindsay@mainfreight.com.au>; Wayne Harris <wayneh@mainfreight.com.au>"
    Email_BCC = ""
    
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail


        .display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject
        .Attachments.Add (ActiveWorkbook.FullName)
        .HTMLBody = RangetoHTML(rng)




    End With
    
    Windows(rng8 & ".xlsx").Activate
    ActiveWorkbook.Close
    


    Application.ScreenUpdating = True
    
    Windows("KPI Daily Report Template.xlsm").Activate
    Sheets("Dashboard").Select
    Range("J1").Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close


    Application.DisplayAlerts = True


    
End Sub

 

[Pobek]

Hey this works:

recipient = Range("f27").Value
ReqCC = Range("f28").Value
subje = Range("f29").Value
mes = Range("f31").Value
attache = Range("attache").Value
attachepath = Range("attachePath").Value
attchmnt = attachepath & "" & attachepath
SendTo = recipient
Sendcc = ReqCC
Subj = subje
Msg = mes

'SendAt = "10/19/2008 12:30am" 'Date-Time must be in this format

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
olApp.Session.Logon

Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
' .DeferredDeliveryTime = SendAt
.To = SendTo
.cc = Sendcc
.Subject = Subj
.Body = Msg
'.attachments.Add (attchmnt & ".pdf")
.attachments.Add ("C:\Users\POBEK\Documents\Professional\POBEK\POBEK Consulting\Buss\Industry\Payroll\Staff 1 Dated 6 - 2017.pdf")



but I need to be able to parameterize the path of the attchment i.e I need to be able to refer to it as an input. Any suggestion as to how I can get the commented out: '.attachments.Add (attchmnt & ".pdf") to work?

 

[mrshl9898]

Is just the file name the variable?

Try adding these:

dim attache as string
dim attachepath as string

attache = Range("attache").Value 'needs to equal "Staff 1 Dated 6 - 2017.pdf"
attachepath = Range("attachePath").Value 'needs to equal "C:\Users\POBEK\Documents\Professional\POBEK\POBEK Consulting\Buss\Industry\Payroll"
attchmnt = attachepath & "" & attache

.attachments.Add (attchmnt)

 

[Pobek]

I was being absolutely retarded! Reason it didnt work was because I was attaching the path to the PATH as opposed to attaching FILE to path (in my defense it is 12:30 midnight here. Anyway all done now. THANKS A LOT!!!!