VBA Outlook E-mail w/ Text & Attachment

[mst3kr]

Hello. I need some assistance in correcting, improving, simplifying, streamlining, etc., the Mail_Outlook macro found below. This entirety is two macros and one 'Function' macro that I’ve cobbled together from parts found online and some pieces of macros I already had. I think it can be slimmed down a bit, but I haven't been successful in doing it. In the end, the Excel file I'm working on is a multi-tab sales report that, once updated, is saved & then E-mailed out to a large list of people (45+) every day; I want to automate the distribution of the report. Thus, the VBA.

In its current [ugly] state, the macros works fine except for one part:

With Sheets("Email Summary")
Set rngBody = .Range("A1:G16")
rngBody.Copy
End With

This should pull from a particular tab within the file, copy the particular range, and then paste the contents into the body of the E-mail. I’ve used it in other macros and it works, but here it does not and I'm not sure why (based on my novice knowledge of VBA).

In essence, what the E-mail should look like is:

To: Populated by the ‘With Sheets’ portion (which works just fine).
Subject: Sales (which populates fine from the ‘With Mail’ portion).

E-mail Body:
Good Morning,

Attached is the today’s sales report. Please advise with any questions.

Then the content of:

With Sheets("Email Summary")
Set rngBody = .Range("A1:G16")
rngBody.Copy
End With

Outlook E-mail Signature (which populates just fine with the ‘SigString’ portion)



Any help to shore this up and make all the components work would be greatly appreciated!!


Sub Save()
ActiveWorkbook.Worksheets("Sheet1").Select
Range("D9").Select

Dim IntialName As String
Dim sFileSaveName As Variant

IntialName = "Sample Output"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, fileFilter:="Excel Files (*.xlsm), *.xlsm")

If sFileSaveName <> False Then
ActiveWorkbook.SaveAs sFileSaveName
End If

Sub Mail_Outlook_()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Good Morning," & _
"Attached is the today’s sales report. Please advise with any questions."

With Sheets("E-mail")
Set rngTo = .Range("D3")
Set rngSubject = .Range("D4")

End With

With Sheets("Email Summary")
Set rngBody = .Range("A1:G16")
rngBody.Copy
End With

SigString = Environ("appdata") & _
"\Microsoft\Signatures\Greg.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next

With OutMail
.To = rngTo.Value
.Subject = "Sales"
.Attachments.Add ActiveWorkbook.FullName
.HTMLBody = strbody & "
" & Signature
.Display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function