I have Outlook VBA code that looks for a condition to match the exact subject and exact email address in one mailbox and then send a reply (Template) to the recipient of that email.
The script was working but lately is getting
Error 440 for array out of bounds.
When I debug it highlights the line:
Set pa = recips(1).PropertyAccessor"
The code is below.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objNewMailItems As Outlook.Items
'Update the AWS and Azure auto reply template path
Private Const AWS_AUTO_REPLY = "C:\Users\Documents\AWS_New_Account.oft"
Private Const AZURE_AUTO_REPLY = "C:\Users\Documents\Azure_New_Account.oft"
Private Sub Application_Startup()
Dim objMyInbox As Outlook.MAPIFolder
Dim oAccount As Account
Dim Store As Outlook.Store
'Set objNS = Application.GetNamespace("MAPI")
'For Each oAccount In Session.Accounts
' Set Store = oAccount.DeliveryStore
' Set objMyInbox = Store.GetDefaultFolder(olFolderInbox)
' Set objNewMailItems = objMyInbox.Items
' Set objMyInbox = Nothing
' MsgBox "Application_Startup"
'Next
Set objNS = Application.GetNamespace("MAPI")
Set objMyInbox = objNS.Folders("NewCloudAcct#xyz.com").Folders("Inbox")
Set objNewMailItems = objMyInbox.Items
Set objMyInbox = Nothing
MsgBox "Script Starting"
End Sub
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim subjectString As String
Dim senderEmailString As String
Dim recipientEmailString As String
Dim oRespond As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
'MsgBox "objNewMailItems_ItemAdd function call"
'Ensure we are only working with e-mail itemshe
If Item.Class <> olMail Then Exit Sub
subjectString = "" + Item.Subject
senderEmailString = "" + Item.SenderEmailAddress
'GetSMTPAddressForRecipients (Item)
recipientEmailString = ""
Set recips = Item.Recipients
'For Each recip In recips
Set pa = recips(1).PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
'Next
If (InStr(recipientEmailString, "naws") > 0) Or (InStr(recipientEmailString, "xaws") > 0) Or (InStr(recipientEmailString, "saws") > 0) Or (InStr(recipientEmailString, "vcaws") > 0) Or (InStr(recipientEmailString, "daws") > 0) Or (InStr(recipientEmailString, "vaws") > 0) Or (InStr(recipientEmailString, "rovisioningteam") > 0) Then
'MsgBox "D ACCOUNT - DO NOT SEND"
GoTo ENDOFCODE
End If
If InStr(subjectString, "Welcome to your Azure free account") > 0 Then
If InStr(senderEmailString, "azure-noreply#microsoft.com") > 0 Then
' This sends a response back using a template
' Enter the actual path for
Set oRespond = Application.CreateItemFromTemplate(AZURE_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("NewCloudAcct#xyz.com").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
' use this for testing, change to .send once you have it working as desired
'.Display
'.Send
End With
End If
End If
If InStr(subjectString, "[EXT] Welcome to Amazon Web Services") > 0 Then
If InStr(senderEmailString, "no-reply-aws#amazon.com") > 0 Then
' This sends a response back using a template
'MsgBox "AWS CONDITION"
Set oRespond = Application.CreateItemFromTemplate(AWS_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("NewCloudAcct#xyz.com").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
'MsgBox "AWS CONDITION 2"
' use this for testing, change to .send once you have it working as desired
.Display
.Send
End With
End If
End If
ENDOFCODE:
Set oRespond = Nothing
End Sub
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
Function ResolveDisplayNameToSMTP(sFromName) As String
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
End Function
Sub Project1()
End Sub
You run into a message with no recipients, hence the line accessing the very first recipient fails.
recipientEmailString = ""
For Each recip In recips
Set pa = recip.PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
Next
The ItemAdd event can be fired for items that are moved to the folder manually (or created from the ground and saved there). So, there is a chance the Recipients collection will be empty. In that case I'd recommend checking the Recipients.Count property first which returns a long indicating the count of objects in the specified collection.
Also you could use a low-level property which can help with distinguishing between read-only items - the PR_MESSAGE_FLAGS property contains a bitmask of flags that indicate the origin and current state of a message.
Finally, I'd suggest using the GetDefaultFolder method of the Namespace or Store class to retrieve the required folder instead of cryptic names, for example:
objNS.Folders("NewCloudAcct#xyz.com").Folders("Inbox")
If it is the default store you could use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Inbox folder for the user who is currently logged on. The Store.GetDefaultFolder method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
Related
I have a code I found and it works great. However, due to Outlook's max of 500, I have a need to create a loop and count the instances. Below are the primary data columns, The other columns are not relevant to the macro. I cannot seem to write the code to loop, as I am somewhat new to VBA.
Column B - email address
Column F - "x" (lowercase to indicate an email must be sent.
Option Explicit
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
' Change to path of OFT Template (AND user name)
Set OutEmail = objOutlook.CreateItemFromTemplate("C:\Change Notification.oft")
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "F").Value) = "x" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "shared#abccorp.com"
.to = cell.Value
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I am building a patient database. I have code that checks for changes in a specific column. if data in that column reaches a certain range, i make it send an email. Currently when i manually update the column the program works flawlessly, but when i have a date based formula update it - the macro doesn't seem to recognize it.
What could the problem be?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 22 Then Exit Sub
Dim rng As Range
For Each rng In Range("V1:V14")
If (rng.Value < 5 And rng.Value > 1) Then
Call mymacro(rng.Address)
End If
Next rng
End Sub
Private Sub mymacro(theValue As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"The patient that is due is in cell: " & theValue
On Error Resume Next
With xOutMail
.To = "email#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Upcoming Patient"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
the formula that updates the column is
=IF(P7<>"",(P7-TODAY()),"")
I have a table with a field containing multi-valuable as shown below:
In the form, I want to let the user enter a NCR_Num in the textbox then using VBA to do some input validation then add it to the "text_Pool" as shown below:
This Text_Pool has the NCR_Num as the control source so if there is a NCR number added or deleted from it, it will automatically update the NCR_Num field.
I am not quite sure how to handle this data type.
In VBA, I cannot obtain the value from the Text_Pool because I think I need to treat it as an array or recordset
Below is an example of me trying the recordset attempt but obviously I am quite confused on what I am doing:
Public Function get_NCR_Num(SCAR_Num As Integer) As Integer()
Dim dbsMain As DAO.Database
Dim rstMain As DAO.Recordset
Dim childRS As Recordset
Dim sSearchField, sCriteria As String
Set dbsMain = CurrentDb
Set rstMain = dbsMain.OpenRecordset("tbl_SCAR", dbOpenDynaset, dbReadOnly)
Set childRS = rstMain!NCR_Num.Value
sSearchField = "[SCAR_Num]"
sCriteria = sSearchField & " = " & [SCAR_Num]
With rstMain
.MoveLast
.FindFirst (sCriteria)
With childRS
Do While (Not .EOF)
MsgBox (childRS!NCR_Num.Value)
.MoveNext
Loop
End With
End With
rstMain.Close
dbsMain.Close
Set rstMain = Nothing
Set dbsMain = Nothing
End Function
Any help will be appreciated!
I misunderstood your question, and have updated the answer with the following code. This should do what you want. Replace the code you have in subroutine 'Command_LinkNCR_Click' with the following.
This will: (a) validate nbr exists; (b) add if not present; (c) remove if present;
WARNING!! This code only addresses the one issue you were trying to overcome. However, it makes an update of the same recordset as you are viewing on the form, so there may be an issue if your form is 'Dirty'.
Give this a try and let me know if you have questions.
Private Sub Command_LinkNCR_Click()
Dim dbs As DAO.Database
Dim rsMain As DAO.Recordset
Dim rsChild As DAO.Recordset
Dim strSQL As String
Dim blnMatch As Boolean
If IsNull(Me.Text_NCR) Or Me.Text_NCR = "" Then
MsgBox "No value entered for NCR_Num", vbOKOnly, "Missing Value"
Exit Sub
End If
blnMatch = False
Set dbs = CurrentDb
' Only need to work on the current record
strSQL = "select * from tbl_SCAR where SCAR_Num = " & Me!SCAR_Num & ";"
Set rsMain = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsMain.EOF Then
' Should never happen
Else
Set rsChild = rsMain!NCR_Num.Value
If rsChild.EOF Then ' If no values yet, add this new one
MsgBox "Add item"
Else
Do While Not rsChild.EOF
' See if we have a match...
If Int(rsChild.Fields(0)) = Int(Me.Text_NCR) Then
blnMatch = True
rsChild.Delete ' Delete item
Exit Do
End If
rsChild.MoveNext
Loop
If blnMatch = False Then ' Need to Add it
rsMain.Edit
rsChild.AddNew
rsChild.Fields(0) = Me.Text_NCR
rsChild.Update
rsMain.Update
End If
End If
End If
'rsChild.Close
rsMain.Close
dbs.Close
Set rsMain = Nothing
Set rsChild = Nothing
Set dbs = Nothing
Me.Refresh
End Sub
How do I identify all the selected checkboxes in a frame in a user form and assign them to an array so that I can either/both: duplicate the selected checkboxes in one or more other frames & use the array to fill out spreadsheet cells?
Kind of a two-part question, but I think they go hand-in-hand (I'm not sure). I have a userform with multiple frames, and a lot of checkboxes inside each (SS) - I have a standard naming convention for all of them (explained bottom).
I will need to identify which checkboxes are selected (and the selection in the comboboxes) so I can put all that into a spreadsheet. I also will need the option for the user to copy all the selected checkboxes (and the selection in the comboboxes) from one frame to one to three of the other frames if s/he wants to. I have a "Copy" button that initializes a short userform to select which frame to copy from and which frame(s) to copy to. (For example: the ability to copy all the selections from the "Alpha Antennas" frame to one or more of "Beta Antennas" frame, "Gamma Antennas" frame, "Delta Antennas" frame.) Really stuck on what to do in the main form once I get that? I think one array will get me the two functions I need (copying one frame to another and filling out the spreadsheet) - but I don't know the next step. Any help?
Some code/naming/SS:
The command button that loads the main form:
Sub CreateADS()
Dim oneForm As Object
'==========================================================
'On Error GoTo ErrHandler 'Trying to catch errors - will input more down there, later
ADSinputform.Show
For Each oneForm In UserForms
Unload oneForm
'Unload ADSinputform
Next oneForm
End Sub
The main Userform beginning code:
Dim myCheckBoxes() As clsUFCheckBox
Private Sub UserForm_Activate()
'======================================================
'couple pre-initialization things here
'======================================================
End Sub
Private Sub UserForm_Initialize()
Dim chBox As Control
Dim comboBox As Control
Dim arrFreq() As String
Dim i As Long
Dim siteName As String
Dim ctrl As Object, pointer As Long
ReDim myCheckBoxes(1 To Me.Controls.Count)
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then
pointer = pointer + 1
Set myCheckBoxes(pointer) = New clsUFCheckBox
Set myCheckBoxes(pointer).aCheckBox = ctrl
End If
Next ctrl
ReDim Preserve myCheckBoxes(1 To pointer)
'Use the Split function to create two zero based one dimensional arrays.
arrFreq = Split("Unused|GSM,850|GSM,1900|UMTS,850|UMTS,1900|CDMA,850|LTE,700|LTE,850|LTE,1900|LTE,2100|LTE,2300", "|")
For Each comboBox In ADSinputform.Controls
If TypeOf comboBox Is MSForms.comboBox Then
For i = 0 To UBound(arrFreq)
'Use .List property to write array data to all the comboBoxes
comboBox.List = arrFreq
Next i
End If
Next
MsgBox "This pops up at the end of initialization"
End Sub
Private Sub cmdCopy_Click()
Dim chkBox As Control
Dim cmbBox As Control
Dim frmSource As MSForms.Frame
'Dim frmSource As String
Dim valSectCopy1 As String 'to validate that a sector is filled in
Dim valSectCopy2 As String 'to validate that an antenna is filled in
Dim valPortCopy As String 'to validate that a port is filled in
Set frmSource = SectorsFrame
valSectCopy1 = ""
valSectCopy2 = ""
valPortCopy = ""
For Each chkBox In frmSource.Controls 'Sector-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy1 = chkBox.Tag
valSectCopy2 = valSectCopy1
Set frmSource = Controls(valSectCopy1)
Exit For
End If
Next chkBox
If valSectCopy1 <> "" Then
For Each chkBox In frmSource.Controls 'Antenna-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy2 = chkBox.Tag
valPortCopy = valSectCopy2
Set frmSource = Controls(valSectCopy2)
Exit For
End If
Next chkBox
Else
GoTo NoSource
End If
If valSectCopy2 <> valSectCopy1 Then
For Each cmbBox In frmSource.Controls 'Port-level frame
If TypeName(cmbBox) = "ComboBox" And cmbBox.Value <> "Frequency" Then
valPortCopy = cmbBox.Value
Exit For
End If
Next cmbBox
Else
GoTo NoSource
End If
If valSectCopy2 = valPortCopy Then
GoTo NoSource
End If
CopySector.Show
If CopySector.destSectCopy <> "" And CopySector.srcSectCopy <> "" Then
MsgBox "Copying the " & CopySector.srcSectCopy & _
" sector to " & CopySector.destSectCopy & " sector(s)."
Unload CopySector
Exit Sub
Else
Exit Sub
End If
NoSource:
MsgBox "You have not filled in a sector to copy." & vbCrLf & _
"Please fill out sector info for at least one sector and try again."
Exit Sub
End Sub
The questionnaire userform code:
Public srcSectCopy As String
Public destSectCopy As String
Private Sub cmdCopy_Click()
Dim optBtn As Control
Dim chkBox As Control
srcSectCopy = ""
destSectCopy = ""
For Each optBtn In Me.Controls
If TypeName(optBtn) = "OptionButton" Then
If optBtn.Value = True Then
srcSectCopy = optBtn.Tag
End If
End If
Next optBtn
If srcSectCopy = "" Then
MsgBox "You have not selected a sector to copy." & vbCrLf & _
"Please select a sector to copy from and try again."
Exit Sub
End If
For Each chkBox In Me.Controls
If TypeName(chkBox) = "CheckBox" Then
If chkBox.Value = True Then
If destSectCopy = "" Then
destSectCopy = chkBox.Tag
Else
destSectCopy = destSectCopy & ", " & chkBox.Tag
End If
End If
End If
Next chkBox
If destSectCopy = "" Then
MsgBox "You have not selected any sectors to copy to." & vbCrLf & _
"Please select one or more sectors to be duplicated and try again."
Exit Sub
End If
Msg = "this will copy the " & srcSectCopy & _
" sector to " & destSectCopy & " sector(s)." & vbCrLf & _
"Do you want to continue with the operation?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_Initialize()
End Sub
Private Sub AlphaSect_OptBtn_Change()
Select Case (AlphaSect_OptBtn.Value)
Case True: AlphaSect_CheckBox.Enabled = False
AlphaSect_CheckBox.Value = False
Case False: AlphaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub BetaSect_OptBtn_Change()
Select Case (BetaSect_OptBtn.Value)
Case True: BetaSect_CheckBox.Enabled = False
BetaSect_CheckBox.Value = False
Case False: BetaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub GammaSect_OptBtn_Change()
Select Case (GammaSect_OptBtn.Value)
Case True: GammaSect_CheckBox.Enabled = False
GammaSect_CheckBox.Value = False
Case False: GammaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub DeltaSect_OptBtn_Change()
Select Case (DeltaSect_OptBtn.Value)
Case True: DeltaSect_CheckBox.Enabled = False
DeltaSect_CheckBox.Value = False
Case False: DeltaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub cmdCancel_Click()
Msg = "Are you sure you want to cancel and exit without copying?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Unload Me
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
' user clicked the X button
' cancel unloading the form, use close button procedure instead
Cancel = True
cmdCancel_Click
End If
End Sub
The following class:
Option Explicit
Public WithEvents aCheckBox As MSForms.CheckBox
Private Sub aCheckBox_Click()
Dim chBox As Control
Dim chBoxTag As String
chBoxTag = aCheckBox.Tag
If Right(aCheckBox.Parent.Name, 10) = "Port_Frame" Then
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Enabled = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Enabled = False
End If
Else
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Visible = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Visible = False
For Each chBox In ADSinputform.Controls(chBoxTag).Controls
If TypeOf chBox Is MSForms.CheckBox Then chBox.Value = False
Next
End If
End If
End Sub
I'm not sure this can be done, and I'm not real sure where to even start with it. I know I can loop through all the controls and read the state or the combobox selection, but what to do after that?
Naming:
Frames: "AlphaSect_Frame", "BetaSect_Frame", "GammaSect_Frame"
First-Level Checkboxes: "A1Checkbox", "A2Checkbox", "A3Checkbox"... "B1Checkbox", "B2Checkbox"... "C1Checkbox", "C2Checkbox"
Second-Level Checkboxes: "A1P1Checkbox", "A1P2Checkbox", "A2P1Checkbox", "A2P2Checkbox"... "B1P1Checkbox", "B1P2Checkbox", "B2P1Checkbox", "B2P2Checkbox"... "C1P1Checkbox", "C1P2Checkbox", "C2P1Checkbox", "C2P2Checkbox"
Userform Screenshots:
Here's a simple example for a form with two frames, each of which has two checkboxes:
Dim f1 As Frame, f2 As Frame, c As Control
Set f1 = Me.Frame1 'has checkboxes "f1cb1", "f1cb2"
Set f2 = Me.Frame2 'has checkboxes "f2cb1", "f2cb2"
'loop over all controls in Frame 1
For Each c In f1.Controls
If TypeName(c) = "CheckBox" Then
'set the value of the corresponding control in the other fame
Me.Controls(Replace(c.Name, "f1", "f2")).Value = c.Value
End If
Next c
Im looking for a VBScript that will automatically send an email to each person on a list of contacts I have in an excel tabel using a mail merge.
Any help would be much appreciated and if you need more info just ask :)
Basically I have this code
Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message." &vbCrLf & vbCrLf
.Importance = olImportanceHigh 'High importance
' Resolve each Recipient's name.
For Each ObjOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
But I need it to, instead of creating an email, it uses a mail merge, and the email is to be sent to everyone on a list stored in an excel sheet, problem is, I have no idea how to do this so any help would be great!
Thanks
This will send one email to each person listed in an excel file. For this example, the name is in column A, the email address is in column B and the subject is in column C. Create a template in the drafts folder and set the subject to "Template". In the template email, use {} around any field you want to replace with another. In this example, {name} is replaced with the name from column A. Insert the {image} tag where you want the image to go. I'm assuming you want the same image since it's a corporate logo, so you just define the path in the SendMessage Sub. This will add the image as an attachment, there is no easy way to get around that but it will be embedded into the body of the email.
set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open ("H:\Book1.xls")
'skip header row. set to 1 if you
'don't have a header row
set sh = wb.Sheets("Sheet1")
row = 2
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "H:\Scripts\Batch\pic.png", 80,680
row = row + 1
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
End if
Next
wb.close
set wb = nothing
set app = nothing
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{name}", DisplayName)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function