Option Explicit
Public gvFile
Public gcolEmails As New Collection
Public Const kFILE = "c:\temp\File2mail.xls"
Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
Dim vPage
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application") 'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application") 'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = pvTo
.Subject = pvSubj
.Attachments.Add pvFile, olByValue, 1
.HTMLBody = "<BODY>" & pvBody & "<p> </p><IMG src =" & pvFile & "</BODY>"
'test with this
.Display True
'to send email, use this:
'.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function
Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
MsgBox "Unable to Get" & className & ", attempting to CreateObject"
Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
Public Sub collectEmailList()
Dim vTo, vWord, vName, vEmail
On Error GoTo errAdd
Set gcolEmails = New Collection
'cycle thru the list of email addrs
Range("D2").Select
While ActiveCell.Value <> ""
vEmail = ActiveCell.Offset(0, 0).Value
vWord = vEmail
'vName = ActiveCell.Offset(0, 1).Value
'vWord = vName & "~" & vEmail
gcolEmails.Add vEmail, vWord 'add email to collection
ActiveCell.Offset(1, 0).Select 'next row
Wend
'free memory
'Set gcolEmails = Nothing
Exit Sub
errAdd:
If Err = 457 Then Resume Next 'prevent error for dupes
MsgBox Err.Description, , Err
Exit Sub
Resume
End Sub
Public Sub SendAllEmails()
Dim i As Integer
Dim vEmail, vName, vSubj, vBody, vFile
SetWarnings False
collectEmailList
For i = 1 To gcolEmails.Count
vName = ""
vEmail = gcolEmails(i)
'EMAIL THE DATA
vSubj = Range("G10").Value
vBody = Range("G12").Value
vFile = Range("G14").Value
Send1Email vEmail, vSubj, vBody, vFile
Next
SetWarnings True
End Sub
Private Sub SetWarnings(ByVal pbOn As Boolean)
Application.DisplayAlerts = pbOn 'turn off sheet compatability msg
Application.EnableEvents = pbOn
Application.ScreenUpdating = pbOn
End Sub
