I am trying to display all emails created with a loop, one at a time.
In the code below but I want to add an option to either send the emails automatically, or see them displayed and then send them manually.
While it opens the email item and displays it, when it loops it closes the previous one and opens a new one. I would like to open one and then another one as the loop goes.
Sub Test()
Dim i As Integer
Dim wB As Workbook: Set wB = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wB.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wB.Worksheets("Email Format")
Dim LastRowsData As Integer
Dim LastRowEmail As Integer
Dim OA As Outlook.Application: Set OA = New Outlook.Application
Dim msg As Outlook.MailItem: Set msg = OA.CreateItem(olMailItem)
Dim Recipient As String
Recipient = Worksheets("Email Format").Range("A2")
LastRowsData = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
LastRowEmail = Worksheets("Email Format").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRowsData
If Not IsError(Application.Match(wsD.Range("H" & i).Value, _
wsD.Range("A1:A" & LastRowsData), 0)) Then
LastRowEmail = LastRowEmail + 1
wsE.Range("A" & LastRowEmail).Value = wsD.Range("G" & i).Value
End If
Next i
For i = 2 To LastRowEmail
With msg
.BodyFormat = olFormatHTML
.HTMLBody = wsE.Range("D" & i).Value
.To = wsE.Range("A" & i).Value
.Subject = wsE.Range("C" & i).Value
.Display
End With
Next i
End Sub
Bring Set msg = OA.CreateItem(olMailItem) into your second FOR loop. Then have a msgbox at the end to ask the user if they want to send the msg. If they do, send the msg. If they dont, display a second msg where the user has to click on continue before creating a new item – Zac yesterday
Related
Right now I have code which opens e-mail if ID given in user-form(TextBox1INC) is found in Column1, but let's say I have two e-mails or whatever the number is and I want to open all of them and not only one. How Do I put loop inside this code to make this work ?
Private Sub CommandButton8showemail_Click()
Dim wsArch As Worksheet
Dim lastrow, a As Long
Dim strEmail, strEmailLoc As String
Dim OutMejlik As Outlook.Application
Dim msg As Outlook.MailItem
Set wsArch = ThisWorkbook.Sheets("Emails_arch")
lastrow = Sheets("Emails_arch").Range("A" & Rows.Count).End(xlUp).Row
With wsArch
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Set OutMejlik = CreateObject("Outlook.Application")
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
Exit Sub
End If
Next a
End With
End Sub
Currently in the loop you are exiting as soon as the first item is displayed to a user:
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Set OutMejlik = CreateObject("Outlook.Application")
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
Exit Sub
End If
Next a
End With
If you remove the Exit Sub part the code will continue running and opening items as you need. But also I'd recommend creating a new Outlook Application outside of the loop to avoid creation each time (even if Outlook is a singleton and only one instance can be created).
Set OutMejlik = CreateObject("Outlook.Application")
With wsArch
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Dim msg As Outlook.MailItem
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
End If
Next a
End With
I am trying to send with another account however the VBA defaults to the main email.
I want to use no_reply mailbox however it uses firstname.lastname#company.com.
I even changed the no_reply to my default email by going into account settings in Outlook.
I checked while running the code if it is referring to the no_reply when it creates a new mail window, and it does at line Set OutAccount = myMail.Session.Accounts.Item(1) which shows as no_reply. However the email message shows first.last#company.com.
Sub Send_EmailV21()
Dim outlookApp As Outlook.Application
Dim myMail As Outlook.MailItem
Dim lastrow As Long
Dim i As Integer
Dim Sheet As Worksheet
Dim OutAccount As Outlook.Account
Application.ScreenUpdating = False
On Error Resume Next
lastrow = ThisWorkbook.Worksheets("Sheet1").Range("A1").End(xlDown).Row
For i = 2 To lastrow
'If ThisWorkbook.Worksheets("Sheet2").Range("T" & i) = "No" Then
Set outlookApp = New Outlook.Application
Set myMail = outlookApp.CreateItem(olMailItem)
'Set OutAccount = myMail.Session.Accounts.Item(1)
source_file = ThisWorkbook.Worksheets("Sheet1").Range("E" & i).Value
source_file2 = ThisWorkbook.Worksheets("Sheet1").Range("F" & i).Value
Set Sheet = ThisWorkbook.Worksheets("Sheet1")
myMail.Attachments.Add source_file
myMail.Attachments.Add source_file2
'Set myMail.SendUsingAccount = myMail.Session.Accounts.Item(1)
myMail.To = ThisWorkbook.Worksheets("Sheet1").Range("D" & i).Value
myMail.Subject = "Subject Line"
myMail.HTMLBody = "whatever i want to write in the email"
myMail.Display
myMail.Send
ThisWorkbook.Worksheets("Sheet1").Range("G" & i) = "Yes"
'Else
'End If
Application.ScreenUpdating = True
Next i
End Sub
Adding the following line worked.
myMail.SentOnBehalfOfName = "blah#company.com"
I'd suggest iterating over all accounts configured in the profile and choose the required one. By using indexes you may choose a wrong account mistakenly.
' Loop over the Accounts collection of the current Outlook session.
Dim accounts As Outlook.Accounts = application.Session.Accounts
Dim account As Outlook.Account
For Each account In accounts
' When the email address matches, return the account.
If account.SmtpAddress = smtpAddress Then
Return account
End If
Next
See Send an email given the SMTP address of an account for more information.
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
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.
I have a workbook where I am building an automated e-mail but I want that e-mail to contain data that is stored in a second workbook. Please see my code below, I did change some variable names/data just for confidentiality so hopefully that doesn't make it too difficult to read.
Option Explicit
Sub Button1_Click()
Dim objExcel As Object
Dim wb1 As Workbook
Dim ws1 as Worksheet
Set objExcel = CreateObject("Excel.Application")
Set wb1 = objExcel.Workbooks.Open(ThisWorkbook.Path & "\wb1.xls")
Set ws1 = wbStoreList.Worksheets("Sheet1")
Dim filePaths As Variant
Dim msg As String
Dim i As Integer
Dim objApp As Object
Dim objMail As Object
Dim fileName As String
Dim emailAddress As String
Dim subject As String
Dim name As String
Dim otherName As String
Dim rowNumber As Range
Set objApp = CreateObject("Outlook.Application")
filePaths = Application.GetOpenFilename(MultiSelect:=True)
If (IsArray(filePaths)) Then
For i = LBound(filePaths) To UBound(filePaths)
Set objMail = objApp.CreateItem(olMailItem)
fileName = Dir(filePaths(i))
If (Len(fileName) = 8) Then
emailAddress = "email" & Mid(fileName, 1, 3) & "#emailaddress.ca"
ElseIf (Len(fileName) = 9) Then
emailAddress = "email" & Mid(fileName, 1, 4) & "#emailaddress.ca"
End If
subject = "Confidential"
With ws1
'On Error Resume Next
Set rowNumber = .Range(.Cells(8, 1), .Cells(8, 10000)).Find(What:="311", LookIn:=xlValues).Row
End With
MsgBox rowNumber
dataFound:
objMail.Recipients.Add emailAddress
objMail.subject = subject
objMail.Attachments.Add filePaths(i)
objMail.Body = name & ", " & "(" & otherName & ")" & vbNewLine & vbNewLine & "Please see attached file."
objMail.Display
Next i
Else
MsgBox "No files were selected"
End If
End Sub
The error is on the line with:
Set rowNumber = .Range(.Cells(8, 1), .Cells(8, 10000)).Find(What:="311", LookIn:=xlValues).Row
Not sure if you can directly get the row number like that because rowNumber is a Range (according to your dim statement). Give it a try and break it down into two lines:
Set rowNumber = .Range(.Cells(1, 8), .Cells(10000, 8)).Find(What:="311", LookIn:=xlValues)
and then
If Not rowNumber is Nothing then lngNumber = rowNumber.Row
Note that I am using a new variable which should be of type long.
Dim lngRowNumber as Long
By the way: in your case Integer would actually suffice over Long.