SAMPLE SCRIPT EMAIL AUTO– INDOTRAININGCENTER.
COM
Option Base 1 'Force Arrays to begin at 1
Option Explicit 'Force variable declaration
'Module level declarations
Dim BlondeCount As Integer 'Holds the count of blondes
Dim MyArray() 'Holds the names of the recipients
Dim MyCounter As Integer 'Used to populate the array
Dim MySubject As String 'Holds the eMail subject
Sub SunScreenMail()
MySubject = "Check out our new sunscreens!"
'Select the correct sheet
ShData.Select
'Get the count of blondes
BlondeCount = Application.WorksheetFunction.CountIf(Range("E:E"), "Blonde")
'Re-dimesion the array (now we know how many blondes there are)
'2 elements...1 for the first name, 1 for the email address
ReDim MyArray(BlondeCount, 2)
'Find the first "Blonde" in column E
Columns("E:E").Select
Selection.Find(What:="Blonde", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'Select the first found value
ActiveCell.Select
'Initialise counter
MyCounter = 0
'Loop to get data
While ActiveCell.Value <> ""
'See if we have caught all entries yet
If MyCounter = BlondeCount Then GoTo eMailSection
'Otherwise loop to get all the data
If ActiveCell.Value = "Blonde" Then
'Increase the value of counter by 1
MyCounter = MyCounter + 1
'Get the first name
MyArray(MyCounter, 1) = _
Left(ActiveCell.Offset(0, -4), InStr(ActiveCell.Offset(0, -4).Value, " ") -
1)
'Get the eMail address
MyArray(MyCounter, 2) = ActiveCell.Offset(0, 2).Value
'Move down a row
ActiveCell.Offset(1, 0).Select
Else
'Move down a row
ActiveCell.Offset(1, 0).Select
End If
Wend
'Label (we go here if we get all the entries before we reach the end of the
data set)
eMailSection:
'Loop to send all the emails
For MyCounter = 1 To BlondeCount
'Call the email routine
'Note: as the array was declared at module
'Level, all the variables (the contents) are
'passed to the email sub
eMailRoutine
Next MyCounter
'Go back to top of page
Range("A1").Select
End Sub
Private Sub eMailRoutine()
Dim OutlookApp As Object 'Declare Outlook as an object
SAMPLE SCRIPT EMAIL AUTO– INDOTRAININGCENTER.COM
Dim OutgoingEmail As Object 'Declare the email as an object
Dim MyBodyText As String 'Holds the message itself
'Create an object for Outlook
Set OutlookApp = CreateObject("Outlook.Application")
'Create an object for the email
Set OutgoingEmail = OutlookApp.CreateItem(0)
'Build the text for the body of the message (could be read from ranges in
Excel)
MyBodyText = "Hi there " & MyArray(MyCounter, 1) & "," & _
vbNewLine & vbNewLine & _
"We just wanted to let you know about our new range of sunscreens!" & _
vbNewLine & vbNewLine & _
"This range is the best sunscreen ever, and we'd love to send you a
sample."
& _
vbNewLine & _
"Watch out this delivery in the next couple of days" & vbNewLine & _
vbNewLine & vbNewLine & _
"Those nice folks at Excel Essentials."
'Turns off error handling (stops the "someone is trying to send an email"
message)
On Error Resume Next
With OutgoingEmail
.To = MyArray(MyCounter, 2)
'.CC = ""
'.BCC = ""
.Subject = MySubject
.Body = MyBodyText
'.Attachments.Add ("C:Users\Alan\Desktop\Book1.xlsx")
.Send
End With
'Cancels the error trap above
On Error GoTo 0
'Destroy object variables
' (in the reverse order in which we declared them)
Set OutgoingEmail = Nothing
Set OutlookApp = Nothing
End Sub
Private Sub SimpleSendMailOriginalCode()
'This is the original code, which is slightly modified above
'This code uses "Late Binding". This means the code
'can be used from any PC.
Dim OutlookApp As Object 'Declare Outlook as an object
Dim OutgoingEmail As Object 'Declare the email as an object
Dim MyBodyText As String 'Holds the message itself
'Create an object for Outlook
Set OutlookApp = CreateObject("Outlook.Application")
'Create an object for the email
Set OutgoingEmail = OutlookApp.CreateItem(0)
'Build the text for the body of the message (could be read from ranges in
Excel)
MyBodyText = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
'Turns off error handling (stops the "someone is trying to send an email"
message)
On Error Resume Next
With OutgoingEmail
.To = "someone@somewhere.com"
'.CC = ""
SAMPLE SCRIPT EMAIL AUTO– INDOTRAININGCENTER.COM
'.BCC = ""
.Subject = "This is the Subject line"
.Body = MyBodyText
'.Attachments.Add ("C:Users\Alan\Desktop\Book1.xlsx")
.Send
End With
'Cancels the error trap above
On Error GoTo 0
'Destroy object variables
' (in the reverse order in which we declared them)
Set OutgoingEmail = Nothing
Set OutlookApp = Nothing
End Sub
