Need my Emailing Macro to attach files

P

Pobek

Board Regular
Joined
Jul 7, 2015
Messages
99
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
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
Where you have

.Body = Msg
.Attachments.Add (ActiveWorkbook.FullName or file location and book name.xlsx etc.)
 
Upvote 0
mrshl9898 said:
Where you have

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



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")
 
Upvote 0
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"
 
Upvote 0
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

Code: 
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
 
Upvote 0
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?
 
Upvote 0
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)


 
Last edited:
Upvote 0
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!!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Macro to open a new email via Outlook
Replies
3
Views
755
skillilea
S
M
  • Question Question
code to include a column or more based on checkbox
Replies
6
Views
124
mecerrato
M
K
  • Solved
Macro : Email Worksheet As PDF
Replies
3
Views
366
Domenic
D
S
  • Solved
Emailing Only Visible Cells
Replies
2
Views
244
sGraham24
S
P
  • Question Question
Signature is being removed when I run the rest of my VBA
Replies
3
Views
522
rollis13
rollis13

Forum statistics

Threads
1,223,243
Messages
6,170,964
Members
452,371
Latest member
Frana

Share this page

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