Public gcolEmails As Collection
Public Sub SendAllEmails()
Dim i As Integer
Dim vEmails, vFile, vCC
'MsgBox "Have Outlook open."
'SetWarnings False
vFile = ActiveWorkbook.FullName
collectEmailList 'gather all emails
vEmails = BuildBulkList()
Send1Email vEmails, "your data", "body of data", vCC, vFile
'SetWarnings True
MsgBox "Done"
Set gcolEmails = Nothing
End Sub
Private Sub collectEmailList()
Dim vTo, vWord, vName, vEmail, vReg, vCC
On Error GoTo errAdd
Set gcolEmails = New Collection
Sheets("EmailList").Activate 'goto the email list
'cycle thru the list of email addrs
Range("A2").Select
While ActiveCell.Value <> ""
vName = ActiveCell.Offset(0, 0).Value
vEmail = ActiveCell.Offset(0, 1).Value
gcolEmails.Add vEmail, vName 'add email to collection
ActiveCell.Offset(1, 0).Select 'next row
Wend
Exit Sub
errAdd:
If Err = 457 Then Resume Next 'prevent error for dupes
MsgBox Err.Description, , Err
End Sub
Private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, ByVal pvCC, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
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
.CC = pvCC
.Subject = pvSubj
If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
.HTMLBody = pvBody
.Display True
'.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
Resume
End Function
Private 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
Private Function BuildBulkList()
Dim i As Integer
Dim vEList
For i = 1 To gcolEmails.Count
vEList = vEList & gcolEmails(i) & ";"
Next
BuildBulkList = vEList
'MsgBox vEList
End Function