VBA Application-defined error outlook connection - excel

I have the following code and keep having the error "application-defined or object-defined error" and cannot understand why. The tool Microsoft Office 16.0 Object library is activated, I am confident that the error is liked with the line Set outlookMail = outlookApp.CreateItem(0). For sure I am missing something in the connection with outlook.
Sub send_emails()
Dim outlookApp As Object
Dim outlookMail As Object
Dim cell As Range
Dim lastRow As Long
' Create Outlook object
Set outlookApp = CreateObject("Outlook.Application")
' Determine the last row in the worksheet
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
' Loop through each cell in column D
For Each cell In Range("D2:D" & lastRow)
' Check if the date in the cell is 15 days from today
If cell.Value = Date + 15 Then
' Retrieve the corresponding email address, name, and surname
Email = cell.Offset(0, 2).Value
Name = cell.Offset(0, 1).Value
surname = cell.Offset(0, -1).Value
' Create a new email
Set outlookMail = outlookApp.CreateItem(0)
' Set the recipient, subject, and body of the email
outlookMail.To = Email
outlookMail.Subject = "Reminder"
outlookMail.Body = "Dear " & Name & " " & surname & ", this is a reminder that your event is coming up in 15 days. Please make sure to prepare accordingly."
' Set the sender and send the email
outlookMail.SendUsingAccount = outlookApp.Session.Accounts.Item("YOUR EMAIL ADDRESS")
outlookMail.Send
' If the email was sent successfully, color the cell in column E green
cell.Offset(0, 1).Interior.Color = vbGreen
End If
Next cell
' Clean up
Set outlookMail = Nothing
Set outlookApp = Nothing
End Sub

The tool Microsoft Office 16.0 Object library is activated
I suppose you have added a reference to the Outlook object model (a COM reference) in Excel VBA environment. In the code I see that the late-binding technology is used:
Dim outlookApp As Object
Dim outlookMail As Object
' Create Outlook object
Set outlookApp = CreateObject("Outlook.Application")
But at the same time you added a COM object reference for using the early-binding in the code. So, I'd suggest using the New operator and declare all Outlook objects in the code with specific types instead:
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Set outlookApp = New Outlook.Application()
You can read more about early and late binding technologies in the Using early binding and late binding in Automation article.

Send Emails From Excel
Option Explicit
Private Enum eCols
ecSurName = 1 ' C
ecDate = 2 ' D
ecName = 3 ' E
ecEmail = 4 ' F
End Enum
Sub SendEmails()
Const MY_EMAIL As String = "YOUR EMAIL ADDRESS"
On Error GoTo ClearError
' Reference the worksheet.
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
' Reference the range.
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If LastRow < 2 Then Exit Sub ' no data
Dim rg As Range: Set rg = ws.Range("C2", ws.Cells(LastRow, "F"))
' Write the values from the range to an array.
Dim Data(): Data = rg.Value
' Write the matching rows to a collection.
Dim coll As Collection: Set coll = New Collection
Dim r As Long, rDate As Variant
For r = 1 To UBound(Data, 1)
rDate = Data(r, eCols.ecDate)
If IsDate(rDate) Then
If rDate = Date + 15 Then coll.Add r
End If
Next r
If coll.Count = 0 Then Exit Sub ' no matches
' Send the emails.
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim crg As Range, rItem, ErrNum As Long, emCount As Long
Dim olMail As Object, mEmail As String, mName As String, mSurName As String
For Each rItem In coll
mEmail = Data(rItem, eCols.ecEmail)
mName = Data(rItem, eCols.ecName)
mSurName = Data(rItem, eCols.ecSurName)
Set olMail = olApp.CreateItem(0)
With olMail
.To = mEmail
.Subject = "Reminder"
.Body = "Dear " & mName & " " & mSurName _
& ", this is a reminder that your event is coming up " _
& "in 15 days. Please make sure to prepare accordingly."
.SendUsingAccount = olApp.Session.Accounts.Item(MY_EMAIL)
On Error Resume Next ' suppress send error e.g. if invalid email
olMail.Send
ErrNum = Err.Number
On Error GoTo ClearError
End With
' Count and combine cells to be highlighted.
If ErrNum = 0 Then
emCount = emCount + 1
If crg Is Nothing Then
Set crg = rg.Cells(rItem, eCols.ecName)
Else
Set crg = Union(crg, rg.Cells(rItem, eCols.ecName))
End If
End If
Next rItem
ProcExit:
On Error Resume Next
' Highlight cells.
If Not crg Is Nothing Then crg.Interior.Color = vbGreen
' Clean up.
If Not olMail Is Nothing Then Set olMail = Nothing
If Not olApp Is Nothing Then Set olApp = Nothing
' Inform.
MsgBox IIf(emCount = 0, "No", emCount) & " email" _
& IIf(emCount = 1, "", "s") & " sent.", _
IIf(emCount = 0, vbExclamation, vbInformation)
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
Resume ProcExit
End Sub

Related

VBA Outlook mail body does not display (probably due to table pasted into mail body via vba excel)

I'm currently working on a vba excel macro that filters particular rows (based on values in one column), then copies particular columns from the filtered rows & paste them as a table into the outlook email body.
I'd like the table to be pasted after the text in the email body. However, it seems that the table is the only thing that is in the mail body & I can't put the text before the table.
Would much appreciate your advice on how to display the text in the email body before the pasted table. My current: "OutMail.Body = "The body text I want to put before the table" does not work.
EDIT 1 = adjusted according to CDP1802 + added moving rows to archive feature
Code:
Option Explicit Public ws As Worksheet
Public ol As ListObject
Public olRng As Range
Sub CopyTableToEmail()
Dim olCol As Integer, datCol As Integer
Set ws = Sheets("Test1")
Set ol = ws.ListObjects("TbClient")
Set olRng = ol.Range
'remove table filters
ol.ShowAutoFilter = False
'get Valid column
olCol = ol.ListColumns("Valid").Index
'filter table
ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
'select table to copy
Set olRng = ol.Range
'create mail
Call CreateMail
'Change values on Deactivation e-mail sent column
datCol = ol.ListColumns("Deactivation e-mail sent").Index
ol.ListColumns(datCol).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = Range("H1")
'clear table filters
ol.AutoFilter.ShowAllData
'Move rows to the Archive
Call MoveRows
End Sub
Sub CreateMail()
On Error GoTo errHandler
Dim olCol As Integer, rCell As Range, addRng As Range
Dim mailBcc As String, mailCC As String
'Outlook
Dim OutApp As Object, OutInsp As Object, OutMail As Object
'Declare Word Variables
Dim oWrdDoc As Word.Document, oWdEditor As Word.Editors
Dim sText As String
'Range of mail adresses
olCol = ol.ListColumns("Requestor (email)").Index
Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
'get the mail addresses
For Each rCell In addRng
mailBcc = mailBcc & rCell.Value & ";"
mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
Next rCell
' copy table colmns B,J,L
ws.Columns.Hidden = False
ws.Range("A:A,C:I,K:K,M:Z").EntireColumn.Hidden = True
olRng.Copy
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim signature As String
With OutMail
.display ' or send
signature = .body
.cc = mailCC
.Bcc = mailBcc
.Subject = "Openings Tracker"
End With
' Text
sText = "Ladies and gentlemen," & vbCrLf & vbCrLf
'Get the Active Inspector
'Get the document within the inspector
Set OutInsp = OutMail.GetInspector
Set oWrdDoc = OutInsp.WordEditor
With oWrdDoc
.Content.Delete
.Paragraphs.Add.Range.Text = sText
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = signature
End With
ws.Columns.Hidden = False
Application.CutCopyMode = False
exitRoutine:
'clear
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Exit Sub
errHandler:
'Open immediate window to see the error
Debug.Print Err.Number, Err.Description
Resume exitRoutine
End Sub
Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim O As Long
A = Worksheets("Test1").UsedRange.Rows.Count
B = Worksheets("Archive").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Test1").Range("O1:O" & A)
On Error Resume Next
Application.ScreenUpdating = False
For O = 1 To xRg.Count
If CStr(xRg(O).Value) = "OK" Then
xRg(O).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
xRg(O).EntireRow.Delete
If CStr(xRg(O).Value) = "OK" Then
O = O - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Add a paragraph to the word document.
update1 - Filter table, add signature to the end.
update2 - Show only columns B J L
update3 - Added AchiveRows()
Option Explicit
Public ws As Worksheet
Public ol As ListObject
Public olRng As Range
Sub CopyTableToEmail()
Dim olCol As Integer, datCol As Integer
Set ws = Sheets("Test1")
Set ol = ws.ListObjects("tbClient")
Set olRng = ol.Range
'remove table filters
ol.ShowAutoFilter = False
'get Valid column
olCol = ol.ListColumns("Valid").Index
'filter table
ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
'select table to copy
Set olRng = ol.Range
'create mail
Call CreateMail
'clear table filters
ol.AutoFilter.ShowAllData
End Sub
Sub CreateMail()
On Error GoTo errHandler
Dim olCol As Integer, rCell As Range, addRng As Range
Dim mailBcc As String, mailCC As String
' Outlook
Dim OutApp As Object, OutInsp As Object, OutMail As Object
'Declare Word Variables
Dim oWrdDoc As Word.Document, oWdEditor As Word.Editors
Dim sText As String
'Range of mail adresses
olCol = ol.ListColumns("Requestor email").Index
Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
'get the mail addresses
For Each rCell In addRng
mailBcc = mailBcc & rCell.Value & ";"
mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
Next rCell
' copy table colmns B,J,L
ws.Columns.Hidden = False
ws.Range("A:A,C:I,K:K,M:Z").EntireColumn.Hidden = True
olRng.Copy
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim signature As String
With OutMail
.display ' or send
signature = .body
.cc = mailCC
.Bcc = mailBcc
.Subject = "Generic Subject"
End With
' Text
sText = "The body text I want to put before the table" & vbCrLf & vbCrLf
'Get the Active Inspector
'Get the document within the inspector
Set OutInsp = OutMail.GetInspector
Set oWrdDoc = OutInsp.WordEditor
With oWrdDoc
.Content.Delete
.Paragraphs.Add.Range.Text = sText
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = signature
End With
ws.Columns.Hidden = False
Application.CutCopyMode = False
exitRoutine:
'clear
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Exit Sub
errHandler:
'Open immediate window to see the error
Debug.Print Err.Number, Err.Description
Resume exitRoutine
End Sub
Sub ArchiveRows()
Dim ol As ListObject, rng As Range
Dim r As Long, olCol As Long, n As Long
Set ol = Sheets("Test1").ListObjects("tbClient")
olCol = ol.ListColumns("Valid").Index
With ol.DataBodyRange
For r = 1 To .Rows.Count
If UCase(Trim(.Cells(r, olCol).Value)) = "OK" Then
If rng Is Nothing Then
Set rng = .Rows(r)
Else
Set rng = Union(rng, .Rows(r))
End If
End If
Next
End With
If rng Is Nothing Then
n = 0
Else
n = rng.Rows.Count
With Sheets("Archive")
rng.Copy
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
End With
End With
rng.Rows.Delete
Application.CutCopyMode = False
End If
MsgBox n & " rows moved to Archive and deleted"
End Sub

Find e-mail by body and sender

I am trying find e-mail that matches body text and sender.
Each day I check if 300/400 emails were already sent.
I need to iterate through more than 4500 emails.
Sub Check()
Application.Calculation = xlManual
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Dim OutMail As Object
Dim Last As Long
Last = ThisWorkbook.Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set OutNameSpace = OutApp.GetNamespace("MAPI")
Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
Set OutItms = OutFolder.Items
Set numbers = ThisWorkbook().Sheets(2).Range(Cells(2, 2), Cells(Last, 2))
Dim numer As Range
For Each number In numbers
Z = 1
If numer = "" Then GoTo nastepny
For Each OutMail In OutFolder.Items
If InStr(1, OutMail.Body, number, vbTextCompare) <> 0 Then
If InStr(1, OutMail.Sender, "Sender Name", vbTextCompare) <> 0 Then
number.Offset(0, 7) = "Yes"
GoTo nastepny
End If
Else
number.Offset(0, 7) = "No"
End If
nastepny:
Next OutMail, number
Application.Calculation = xlAutomatic
End Sub
This code runs through all e-mails and checks if there is e-mail with correct number in body and correct sender. For more then 4500 e-mails it takes a lot of time to do it one by one.
With Restrict determine whether any item contains applicable text.
https://learn.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Check()
Application.Calculation = xlManual
' Late binding.
' Reference to Microsoft Outlook XX.X Object Library not required.
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutNameSpace = OutApp.GetNamespace("MAPI")
' Assumptions:
' 1 - Inne is the sender
' 2 - Applicable items from Inne in subfolder Inne
Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
Set OutItms = OutFolder.Items
Debug.Print " OutItms.Count.....: " & OutItms.Count
Dim wB As Workbook
Set wB = ThisWorkbook
Dim wS As Worksheet
Set wS = wB.Worksheets(2)
Dim Last As Long
Dim numbers As Range
With wS
'Entries in column 2
Last = .Cells(.Rows.Count, 2).End(xlUp).Row
Set numbers = .Range(.Cells(2, 2), .Cells(Last, 2))
End With
Dim numBer As Range
For Each numBer In numbers
If numBer <> "" Then
Dim strFilter As String
' https://learn.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & numBer & "%'"
Debug.Print strFilter
Dim numBerResults As Object
Set numBerResults = OutFolder.Items.Restrict(strFilter)
Debug.Print " numBerResults.Count.....: " & numBerResults.Count
If numBerResults.Count > 0 Then
numBer.Offset(0, 7) = "Yes"
Else
numBer.Offset(0, 7) = "No"
End If
End If
Next numBer
Application.Calculation = xlAutomatic
Debug.Print "Done."
End Sub

Search by subject for latest email in all folders and reply all

The code below doesn't execute reply all property, hence, I am not able to edit the body of the email and keep the conversation of the email chain.
I think the best option is to use Application.advancesearch as it gives you latest email by searching through all folders. But I do not know how to run it through Excel.
Objective:
1) Search the inbox and subfolders (multiple) and Sent items folder for the latest email for selected "Subject"
2) select the latest email and reply to all
Sub ReplyMail()
' Variables
Dim OutlookApp As Object
Dim IsOutlookCreated As Boolean
Dim sFilter As String, sSubject As String
Dim SentTime As Long
Dim IndoxTime As Long
Dim olEmailIndox As Outlook.MailItem
Dim olEmailSent As Outlook.MailItem
' Get/create outlook object
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlookApp = CreateObject("Outlook.Application")
IsOutlookCreated = True
End If
On Error GoTo 0
Set olEmailIndox = OutlookApp.CreateItem(olMailItem)
Set olEmailSent = OutlookApp.CreateItem(olMailItem)
' Restrict items
sSubject = "Subject 1"
sFilter = "[Subject] = '" & sSubject & "'"
' Main
With OutlookApp.Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(sFilter)
If .Count > 0 Then
.Sort "ReceivedTime", True
Set olEmailSent = .Item(1)
SentTime = olEmailSent.SentOn
End If
End With
With OutlookApp.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
If .Count > 0 Then
.Sort "ReceivedTime", True
Set olEmailInbox = .Item(1)
InboxTime = olEmailInbox.ReceivedTime
End If
End With
If SentTime > InboxTime Then
With olEmailSent
.ReplyAll
.Display
'.body
'.Send
End With
Else
With olEmailInbox
.ReplyAll
.Display
'.body
'.Send
End With
End If
' Quit Outlook instance if it was created by this code
If IsOutlookCreated Then
OutlookApp.Quit
Set OutlookApp = Nothing
End If
End Sub
I have tested the code below and even though you can polish it, should get you started.
Let me know and mark the answer if it helps.
Add in a vba module this code:
Public Sub ProcessEmails()
Dim testOutlook As Object
Dim oOutlook As clsOutlook
Dim searchRange As Range
Dim subjectCell As Range
Dim searchFolderName As String
' Start outlook if it isn't opened (credits: https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba)
On Error Resume Next
Set testOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If testOutlook Is Nothing Then
Shell ("OUTLOOK")
End If
' Initialize Outlook class
Set oOutlook = New clsOutlook
' Get the outlook inbox and sent items folders path (check the scope specification here: https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch)
searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
' Loop through excel cells with subjects
Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A2:A4")
For Each subjectCell In searchRange
' Only to cells with actual subjects
If subjectCell.Value <> vbNullString Then
Call oOutlook.SearchAndReply(subjectCell.Value, searchFolderName, False)
End If
Next subjectCell
MsgBox "Search and reply completed"
' Clean object
Set testOutlook = Nothing
End Sub
Then add a class module and name it: clsOutlook
To the class module add the following code:
Option Explicit
' Credits: Based on this answer: https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
' Event handler for outlook
Dim WithEvents OutlookApp As Outlook.Application
Dim outlookSearch As Outlook.Search
Dim outlookResults As Outlook.Results
Dim searchComplete As Boolean
' Handler for Advanced search complete
Private Sub outlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
'MsgBox "The AdvancedSearchComplete Event fired."
searchComplete = True
End Sub
Sub SearchAndReply(emailSubject As String, searchFolderName As String, searchSubFolders As Boolean)
' Declare objects variables
Dim customMailItem As Outlook.MailItem
Dim searchString As String
Dim resultItem As Integer
' Variable defined at the class level
Set OutlookApp = New Outlook.Application
' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
searchComplete = False
' You can look up on the internet for urn:schemas strings to make custom searches
searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'" ' Use: subject like '%" & emailSubject & "%'" if you want to include words see %
' Perform advanced search
Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName, searchString, searchSubFolders, "SearchTag")
' Wait until search is complete based on outlookApp_AdvancedSearchComplete event
While searchComplete = False
DoEvents
Wend
' Get the results
Set outlookResults = outlookSearch.Results
If outlookResults.Count = 0 Then Exit Sub
' Sort descending so you get the latest
outlookResults.Sort "[SentOn]", True
' Reply only to the latest one
resultItem = 1
' Some properties you can check from the email item for debugging purposes
On Error Resume Next
Debug.Print outlookResults.Item(resultItem).SentOn, outlookResults.Item(resultItem).ReceivedTime, outlookResults.Item(resultItem).SenderName, outlookResults.Item(resultItem).Subject
On Error GoTo 0
Set customMailItem = outlookResults.Item(resultItem).ReplyAll
' At least one reply setting is required in order to replyall to fire
customMailItem.Body = "Just a reply text " & customMailItem.Body
customMailItem.Display
End Sub

Sending multiple emails using data from excel cells using VBA

I've got a spreadsheet of clients with their client name, email address, contact and admin listed.
I want to be able to send an individual email to each client using the data from the rows that the client is listed.
I've got some VBA that I've written (parts obtained from other people) but it's trying to add all the email addresses to the to field and every other field is pulling all the data instead of the relevant row.
I'm fairly new to this VBA stuff and would greatly appreciate some help.
How can I make it draft individual emails per client with the information from just the row the client is listed.
Example data:
Column B has client names from row 3 down
Column C has email addresses from row 3 down
Column E has contact name from row 3 down
Column G has admin name from row 3 down
Here's the VBA:
Option Explicit
Sub AlexsEmailSender()
Dim OutApp As Object
Dim OutMail As Object
Dim lngLastRow As Long
Dim rngMyCell As Range
Dim objEmailTo As Object
Dim strEmailTo As String
Dim objCCTo As Object
Dim strCCTo As String
Dim objContact As Object
Dim strContact As String
Dim objAdmin As Object
Dim strAdmin As String
Dim strbody As String
Dim objClient As Object
Dim strClient As String
Dim strToday As Date
strToday = Date
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Make sure emails are unique
Set objEmailTo = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("C3:C" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objEmailTo.Exists(CStr(rngMyCell)) = False Then
objEmailTo.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strEmailTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objEmailTo.Items)), ";")
'Make sure cc emails are unique
Set objCCTo = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("D3:D" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objCCTo.Exists(CStr(rngMyCell)) = False Then
objCCTo.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strCCTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objCCTo.Items)), ";")
'Make sure contacts are unique
Set objContact = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("E3:E" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objContact.Exists(CStr(rngMyCell)) = False Then
objContact.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strContact = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objContact.Items)), ";")
'Make sure admins are unique
Set objAdmin = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("G3:G" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objAdmin.Exists(CStr(rngMyCell)) = False Then
objAdmin.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strAdmin = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objAdmin.Items)), ";")
'Make sure clients are unique
Set objClient = CreateObject("Scripting.Dictionary")
lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For Each rngMyCell In Worksheets("Sheet1").Range("B3:B" & lngLastRow)
If Len(rngMyCell) > 0 Then
If objClient.Exists(CStr(rngMyCell)) = False Then
objClient.Add CStr(rngMyCell), rngMyCell
End If
End If
Next rngMyCell
strClient = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objClient.Items)), ";")
Application.ScreenUpdating = True
strbody = "Dear " & strContact & "," & vbNewLine & vbNewLine & _
"Say Hello World!" & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Mr A Nother"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strEmailTo
.CC = strCCTo
.BCC = ""
.Subject = strToday & " - Agreement"
.Body = strbody
'.Attachments.Add
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
To Answer Your Question:
I think the reason you are only seeing one email is because you only created one OutMail object. If you want to loop, you need to set the object = nothing before you can create a new one:
Set OutMail = Nothing
It also looks like you are creating a single dictionary that has all of the emails pushed together in the email field, the names pushed together, etc. You need a way to loop through each email you want to send. You could create an array of dictionaries, create a collection of objects, or loop through a range where the data is kept. Looping through a range sounds like it would be the least complicated in this case.
The pseudocode/code looks like this:
'instantiate the outlook object. Use:
Set OutApp = CreateObject("Outlook.Application")
'Create your array of dictionaries or return a range with the data
'Let's call it listOfEmails
For each email in listOfEmails:
'instantiate the mail object. Use:
Set OutMail = OutApp.CreateItem(0)
'The block that creates the email:
With OutMail
.To = strEmailTo
.CC = strCCTo
.BCC = ""
.Subject = strToday & " - Agreement"
.Body = strbody
'.Attachments.Add
.Display
End With
'destroy the object when you are done with that particular email
Set OutMail = Nothing
Next email
Set OutApp = Nothing
Some General Advice:
Breaking your code into smaller pieces can help make things easier to fix and read. It also makes it more reusable for both this project and future projects.
I'm including this feedback because it also makes for easier questions to answer on here.
For example:
A function to check if Outlook is open:
Function isOutlookOpen() As Boolean
'returns true or false if Outlook is open
Dim OutApp As Object
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
isOutlookOpen = False
Else: isOutlookOpen = True
End If
On Error GoTo 0
End Function
A subroutine to send the email that you can call from another sub:
Sub sendEmail(ByVal recTO As String, ByVal subjectContent As String, ByVal bodyContent As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = recTO
'.CC = ""
'.BCC = ""
.subject = subjectContent
.body = bodyContent '.HTMLBody
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
A function to return a range of data:
Function dataRange() As Range
'Returns the range where the data is kept
Dim ws As Worksheet
Dim dataRng As Range
Dim lastRow As Integer
Dim rng As Range
Set ws = Workbooks("outlookEmail.xlsm").Sheets("dataSheetName")
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'still select where the data should go if the data range is empty
If lastRow = 2 Then
lastRow = lastRow + 1
End If
Set dataRange = Range("B3", "G" & lastRow)
End Function
A subroutine to bring it all together:
Sub main()
'This sub does more than one thing, but I'm asuming it's extremely custom ans still relatively short
Dim data As Range
Dim subj As String
Dim recEmail As String
Dim body As String
Dim Row As Range
'check if data exists. Exit the sub if there's nothing
Set data = dataRange
If dataRange.Cells(1, 1).Value = "" Then
MsgBox "Data is empty"
Exit Sub
End If
'Loop through the data and send the email.
For Each Row In data.Rows
'Row is still a range object, so you can access the ranges inside of it like you normally would
recEmail = Row.Cells(1, 2).Value
If recEmail <> "" Then 'if the email is not blank, send the email
subj = Format(Date, "mm.dd.yy") & " - Agreement"
body = "Dear " & Row.Cells(1, 4).Value & "," & vbNewLine & vbNewLine & _
"Say Hello World!" & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Mr A Nother"
Call sendEmail(recEmail, subj, body)
End If
Next Row
End Sub
Very Importantly:
Thank you to Ron De Bruin for teaching me all about sending emails from Outlook using code in Excel VBA
First of all, add
Option Explicit
above all code.
Then correct the errors.
Then:
https://stackoverflow.com/help/mcve
You want to use Excel VBA to achieve Outlook mail delivery?
if so, You can use the following method to get the email address in range.
You can not be so troublesome. You have simpler code to implement.
Sub Send_Email()
Dim rng As Range
For Each rng In Range("C1:C4")
Call mymacro(rng)
Next rng
End Sub
Private Sub mymacro(rng As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
MailBody = "hello"
On Error Resume Next
With OutMail
.To = rng.Value
.CC = ""
.BCC = ""
.Subject = Sheet1.Cells(rng.Row, 1).Value
.Body = Sheet1.Cells(rng.Row, 2).Value
.Display
'.Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
I use the mymacro method to create a message and send it.
I loop through the email addresses("C1:C4").And call mymacro method to send an email to this address.

Updating Distribution lists in a shared mailbox from Excel

I have the following macro that takes a list of email addresses in Excel and creates/updates an Outlook distribution list under the 'My Contacts' section in Outlook.
How can I adapt this code so that it creates/updates the contacts in a shared mailbox called "Shared Test" instead of just on my mailbox?
Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10
Sub test() 'Worksheet_Change(ByVal Target As Range)
Dim outlook As Object ' Outlook.Application
Dim contacts As Object ' Outlook.Items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' Outlook.Recipient
Dim arrData() As Variant
Dim rng As Excel.Range
Dim numRows As Long
Dim numCols As Long
Dim i As Long
Dim msg As String
msg = "Worksheet has been changed, would you like to update distribution list?"
If MsgBox(msg, vbYesNo) = vbNo Then
Exit Sub
End If
Set outlook = GetOutlookApp
Set contacts = GetItems(GetNS(outlook))
'On Error Resume Next
Set myDistList = contacts.Item(DISTLISTNAME)
On Error GoTo 0
If Not myDistList Is Nothing Then
' delete it
myDistList.Delete
End If
' recreate it
Set newDistList = outlook.CreateItem(olDistributionListItem)
With newDistList
.DLName = DISTLISTNAME
.Body = DISTLISTNAME
End With
' loop through worksheet and add each member to dist list
numRows = Range("A1").CurrentRegion.Rows.Count - 1
numCols = Range("A1").CurrentRegion.Columns.Count
ReDim arrData(1 To numRows, 1 To numCols)
' take header out of range
Set rng = Range("A1").CurrentRegion.Offset(1, 0).Resize(numRows, numCols)
' put range into array
arrData = rng.Value
' assume 2 cols (name and emails only)
For i = 1 To numRows
'little variation on your theme ...
Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 1) & "<" & arrData(i, 2) & ">")
'end of variation
objRcpnt.Resolve
newDistList.AddMember objRcpnt
Next i
newDistList.Save
'newDistList.Display
End Sub
Function GetOutlookApp() As Object
'On Error Resume Next
Set GetOutlookApp = CreateObject("Outlook.Application")
End Function
'To My Contacts
Function GetItems(olNS As Object) As Object
Set GetItems = olNS.GetDefaultFolder(olFolderContacts).Items
End Function
Function GetNS(ByRef app As Object) As Object
Set GetNS = app.GetNamespace("MAPI")
End Function
One way to reference a non-default folder is with .CreateRecipient.
The functions in your code do not appear to make it more efficient.
Option Explicit
Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10
Sub test()
Dim outlook As Object ' Outlook.Application
Dim olNs As Object ' Outlook.Namespace
Dim shareRecipient As Object ' outlook.recipient
Dim sharedMaiboxContacts As Object ' outlook.Folder
Dim sharedMaiboxContactsItems As Object ' outlook.items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' outlook.recipient
Set outlook = CreateObject("Outlook.Application")
Set olNs = outlook.GetNamespace("MAPI")
' Enter mailbox name in "sharedMailboxName"
' Email address is not as useful. Even if invalid, cannot fail a resolve
Set shareRecipient = olNs.CreateRecipient("sharedMailboxName")
shareRecipient.Resolve
If shareRecipient.Resolved Then
Set sharedMaiboxContacts = olNs.GetSharedDefaultFolder(shareRecipient, olFolderContacts)
sharedMaiboxContacts.Display
Set sharedMaiboxContactsItems = sharedMaiboxContacts.Items
' This is a valid use of On Error Resume Next
' to bypass a known possible error
'
' Before finalizing the code, test with this commented out
' where you think there should not be an error
' or you may bypass unknown errors, for example when the syntax is wrong.
On Error Resume Next
' A possible known error occurs if the list does not exist.
' myDistList can remain "Nothing" instead of causing an error.
Set myDistList = sharedMaiboxContactsItems.Item(DISTLISTNAME)
' Turn the bypass off. / Turn normal error handling on.
' Place it as soon as possible after On Error Resume Next
On Error GoTo 0
If Not myDistList Is Nothing Then
' delete it
myDistList.Delete
End If
' Add to non default folders
Set newDistList = sharedMaiboxContactsItems.Add(olDistributionListItem)
With newDistList
.DLName = DISTLISTNAME
.body = DISTLISTNAME
End With
Debug.Print olNs.CurrentUser
' Test with yourself
Set objRcpnt = olNs.CreateRecipient(olNs.CurrentUser)
objRcpnt.Resolve
If objRcpnt.Resolved Then
newDistList.AddMember objRcpnt
newDistList.Display
Else
Debug.Print objRcpnt & " not resolved."
End If
Else
Debug.Print shareRecipient & " not resolved."
End If
End Sub

Resources