Automating distribution of emails with excel attachments with VBA

[jackreacher3]

Hi All, thanks for the above coding. I am trying to achieve something very similar, so thought this would be a great place to start.

I need help with VBA code to add to my Excel Distribution list that when run, would look for the path, grab the file that starts with the cost centre number (in Col A), and attach to the email and issue to a pre-defined distribution list.

The distribution list is attached.

Email (column E) will populate in the To: field
Recipients (columns F to I) 2 to 5 in the CC: field
I would want the email heading to be Fixed Text: "Cost Centre report for - May 2013 (obviously this will change depending on the months report which is being created).
Within the Body of the text,
I would like it to say
Dear First name, (column C)
Please find attached a copy of your cost centre report for May 2013 (again month will be determined by the file)
Summary:
Cost centre: (Column A)
Cost centre Description (Column B)
Cost centre Manager: First name & Surname.

With thanks

Signature (TBC)

[mdmackillop]

Just posted for something similar here (http://www.vbaexpress.com/forum/showpost.php?p=289280&postcount=1)

[jackreacher3]

Hi, Yes I saw that, I have attached an excel file beneath my thread. Thanks

[mdmackillop]

You need to set a range name EmailData for the cells in Column A

Option Explicit

'Requires reference to Redemption (http://www.dimastr.com/redemption/)

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim t As Variant
Dim cel As Range
Dim sig As String
Dim Nm As String
Dim Greet As String, Txt As String, Mnth As String
Dim Copies As String

Application.ScreenUpdating = False

Set OutApp = CreateObject("Redemption.RDOSession")
OutApp.Logon

On Error Resume Next

For Each cel In Range("EmailData") 'Create dynamic range to suit

'Create text
Mnth = Split(cel.Offset(, 9), "\")(UBound(Split(cel.Offset(, 9), "\")))
Greet = "Dear " & cel.Offset(, 2) & "," & vbCr & vbCr

Txt = "Please find attached a copy of your cost centre report for " & Mnth & vbCr
Txt = Txt & "Summary:" & vbCr
Txt = Txt & "Cost Centre: " & cel & vbCr
Txt = Txt & "Description: " & cel.Offset(, 1) & vbCr
Txt = Txt & "Cost Centre Manager: " & cel.Offset(, 2) & " " & cel.Offset(, 3) & vbCr

' Create "Copy" list
For Each t In cel.Offset(, 5).Resize(, 4)
If t <> "" Then Copies = Copies & t & "; "
Next



Set OutMail = OutApp.GetDefaultFolder(olFolderOutbox).Items.Add
With OutMail
.to = cel.Offset(, 4)
.CC = Copies
.Subject = "Cost Centre report for - " & Mnth
.Body = Txt & vbCr & vbCr & sig
.Attachments.Add cel.Offset(, 9).Text & ".zip"

.Display '.Send
End With
On Error GoTo 0

Next cel

'Open outlook to send if required
Dim oOutlook As Object
Dim oNameSpace As Object
Dim oInbox As Object
Dim oBox As Object
Dim i As Long

Const ERR_APP_NOTRUNNING As Long = 429
On Error Resume Next
Dim w

' Handle Microsoft outlook
Set oOutlook = GetObject(, "Outlook.Application")
If Err = ERR_APP_NOTRUNNING Then
w = Err
Set oOutlook = CreateObject("Outlook.Application")
End If

Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oBox = oNameSpace.Folders("Outbox")

For i = 1 To oNameSpace.Folders.Count
Set oInbox = oNameSpace.Folders(i)
If Left(oInbox, 7) = "Mailbox" Then
Set oBox = oNameSpace.Folders(i).Folders("Outbox")
Exit For
End If
Next

Shell "Outlook.exe"
oBox.Select
Dim NewHour, NewMinute, NewSecond, WaitTime
NewHour = Hour(Now())
NewMinute = Minute(Now())
NewSecond = Second(Now()) + 5
WaitTime = TimeSerial(NewHour, NewMinute, NewSecond)
Application.Wait WaitTime



If oBox.Items.Count > 0 Then
SendKeys ("%cs")
Do Until oBox.Items.Count = 0
Application.StatusBar = "Sending " & oBox.Items.Count
NewHour = Hour(Now())
NewMinute = Minute(Now())
NewSecond = Second(Now()) + 1
WaitTime = TimeSerial(NewHour, NewMinute, NewSecond)
Application.Wait WaitTime
DoEvents
On Error GoTo Exits:
Loop
End If
Exits:
If Err <> 0 Then MsgBox "Error recorded", vbExclamation
If w > 0 Then oOutlook.Quit
Application.StatusBar = ""

cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Set oOutlook = Nothing
Set oOutlook = Nothing
Set oNameSpace = Nothing
Set oInbox = Nothing
Application.ScreenUpdating = True
MsgBox "Sent"

End Sub

[jackreacher3]

Hi there, it works, a treat thank you.