Create email with multiple recipients from listbox values - vba

I am trying to create an email and populate multiple recipients based off a listbox.
I tried putting the list box column reference in the ".To" line but it gives a null error.
I found code that should loop through the listbox values but it is not populating any recipients.
Public Sub cmdEmailContact_Click()
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim strPath As String
Dim strFilter As String
Dim strFile As String
Dim strFileEnd As String
Dim strEmailRecipients As String
strPath = "C:\Users\username\Desktop\Invoice Test\GCX"
strFilter = Me.txtInvNum
strFileEnd = ".pdf"
strFile = Dir(strPath & strFilter & strFileEnd)
strEmailRecipients = ""
For N = 0 To Me.lstContacts.ListCount - 1
If Me.lstContacts.Selected(N) = True Then
strEmailRecipients = strEmailRecipients & "; " & Me.lstContacts.Column(3, N)
End If
Next N
strEmailRecipients = Mid(strEmailRecipients, 3)
If strFile <> "" Then
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = strEmailRecipients
''.cc = ""
''.bcc = ""
.Subject = "text here"
.SentOnBehalfOfName = "emailname"
.HTMLBody = "text here"
.Attachments.Add (strPath & strFilter & strFileEnd)
'.Send
.Display
End With
Else
MsgBox "No file matching " & strPath & strFilter & strFileEnd & " found." & vbCrLf & _
"Process has been stopped."
Exit Sub
End If
End Sub
I expect strEmailRecipients to equal a semi-colon separated list of email addresses based off the listbox. There are no error messages.

Rather than building a semi-colon delimited string to populate the To property of the MailItem object, you may instead want to modify the contents of the Recipients collection when adding recipients (independent of the recipient type) to a MailItem object.
Adding an item to the Recipients collection using the Add method will yield a Recipient object, which has a Type property which may be used to designate the recipient as either to, cc, or bcc by setting the property to olTo, olCC, or olBCC (or 1, 2, or 3 if using late binding).
Hence the construction of the email might become something along the lines of the following:
Dim idx
With MailOutLook
With .Recipients
For Each idx In lstContacts.ItemsSelected
With .Add(lstContacts.ItemData(idx))
.Type = olTo
End With
Next idx
End With
.BodyFormat = olFormatRichText
' ... etc.
End With

Related

How to get the e-mail addresses in the CC field?

I found code in How to get the sender’s email address from one or more emails in Outlook?.
I need to get the e-mail addresses of the CC field as well.
Sub GetSmtpAddressOfSelectionEmail()
Dim xExplorer As Explorer
Dim xSelection As Selection
Dim xItem As Object
Dim xMail As MailItem
Dim xAddress As String
Dim xFldObj As Object
Dim FilePath As String
Dim xFSO As Scripting.FileSystemObject
On Error Resume Next
Set xExplorer = Application.ActiveExplorer
Set xSelection = xExplorer.Selection
For Each xItem In xSelection
If xItem.Class = olMail Then
Set xMail = xItem
xAddress = xAddress & VBA.vbCrLf & " " & GetSmtpAddress(xMail)
End If
Next
If MsgBox("Sender SMTP Address is: " & xAddress & vbCrLf & vbCrLf & "Do you want to export the address list to a txt file? ", vbYesNo, "Kutools for Outlook") = vbYes Then
Set xFldObj = CreateObject("Shell.Application").BrowseforFolder(0, "Select a Folder", 0, 16)
Set xFSO = New Scripting.FileSystemObject
If xFldObj Is Nothing Then Exit Sub
FilePath = xFldObj.Items.Item.Path & "\Address.txt"
Close #1
Open FilePath For Output As #1
Print #1, "Sender SMTP Address is: " & xAddress
Close #1
Set xFSO = Nothing
Set xFldObj = Nothing
MsgBox "Address list has been exported to:" & FilePath, vbOKOnly + vbInformation, "Kutools for Outlook"
End If
End Sub
Function GetSmtpAddress(Mail As MailItem)
Dim xNameSpace As Outlook.NameSpace
Dim xEntryID As String
Dim xAddressEntry As AddressEntry
Dim PR_SENT_REPRESENTING_ENTRYID As String
Dim PR_SMTP_ADDRESS As String
Dim xExchangeUser As exchangeUser
On Error Resume Next
GetSmtpAddress = ""
Set xNameSpace = Application.Session
If Mail.sender.Type <> "EX" Then
GetSmtpAddress = Mail.sender.Address
Else
PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
xEntryID = Mail.PropertyAccessor.BinaryToString(Mail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Set xAddressEntry = xNameSpace.GetAddressEntryFromID(xEntryID)
If xAddressEntry Is Nothing Then Exit Function
If xAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or xAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set xExchangeUser = xAddressEntry.GetExchangeUser()
If xExchangeUser Is Nothing Then Exit Function
GetSmtpAddress = xExchangeUser.PrimarySmtpAddress
Else
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
GetSmtpAddress = xAddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End If
End If
End Function
How could I adapt the code to include the e-mail addresses from the CC field as well?
I tried setting Recipients but couldn't get the desired outcome.
You need to replace the GetSmtpAddress function with your own where you could get the CC recipients in the following way (a raw sketch):
Function GetSmtpAddress(Mail As MailItem) as String
Dim emailAddress as String
Dim recipient as Outlook.Recipient
Dim recipients as Outlook.Recipients
Set recipients = Mail.Recipients
For Each recipient In recipients
If recipient.Type = olCC Then
If recipient.AddressEntry.Type = "EX" Then
emailAddress = emailAddress & " " & recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
emailAddress = emailAddress & " " & recipient.Address
End If
End If
Next
Return emailAddress
End Function
You may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Loop through all recipients in the MailItem.Recipients collection, check that Recipient.Type = olCC. For each Recipient object use Recipient.Address. Note that you can end up with EX type addresses (instead of SMTP). Check that Recipient.AddressEntry.Type is "SMTP". If it is not, use Recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress instead (do check for nulls).

Outlook reply with individual recipient names (sender name of original email)

I have created a macro in Outlook VBA below that replies with the sender first name added to the greeting, adds some text for the body, and adds a signature in the fonts I want.
What I need help with is getting the macro to pull ALL of the names of the senders, assigning a value to them that I can then place elsewhere in the body of the email. If that cannot be done, I would settle for just getting all of the names into the greeting, though it is much preferred to be able to move the names around.
Example: sender was Name1;Name2
Currently, this macro will pull only Name1 (giving "Dear Name1,"), but
I would like to get to "Dear Name1 and Name2," at the very least.
Best would be able to have Name1 be in the greeting, then Name2 is placed in the body of the text.
I believe I have taken this as far as I can on my own and now turn to you experts for assistance! Thank you!!
Sub AutoAddGreetingtoReply()
Dim oMail As MailItem
Dim oReply As MailItem
Dim GreetTime As String
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim R As Outlook.Recipient
Dim strGreetName As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
strbody = "<H3><B></B></H3>" & _
"<br><br><B></B>" & _
"Please visit this website to view your transactions.<br>" & _
"Let me know if you have problems.<br>" & _
"Questions" & _
"<br><br>Thank you"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\90 Days.htm"
On Error Resume Next
If Dir(SigString) <> "" Then
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set oReply = oMail.ReplyAll
With oReply
.CC = ""
.HTMLBody = "<Font Face=calibri>Dear " & strGreetName & "," & R1 & strbody & "<br>" & Signature
.Display
End With
End Sub
Given a string "First Last" then get the right side of the string like this
sndrName = oMail.SenderName
lastName = right(sndrName, len(sndrName) - InStr(1, sndrName, " "))
Using the format in your code:
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
lastName = right(oMail.SenderName, len(oMail.SenderName) - InStr(1, oMail.SenderName, " "))
If there is a space in the text InStr returns the position. https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/instr-function
Original mail has one sender. A ReplyAll has recipients, including the original mail sender.
Option Explicit
Private Sub ReplyFirstNames()
Dim oMail As mailitem
Dim oReply As mailitem
Dim strGreetName As String
Dim strGreetNameAll As String
Dim i As Long
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.currentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set oReply = oMail.ReplyAll
With oReply
Debug.Print "The reply all recipients are:"
For i = 1 To .Recipients.count
Debug.Print .Recipients(i)
' Given the format First Last
strGreetName = Left(.Recipients(i), InStr(1, .Recipients(i), " ") - 1)
strGreetNameAll = strGreetNameAll & strGreetName & ", "
Next i
Debug.Print strGreetNameAll
' remove extra comma and space from end
strGreetNameAll = Left(strGreetNameAll, Len(strGreetNameAll) - 2)
Debug.Print strGreetNameAll
.htmlbody = "<Font Face=calibri>" & strGreetNameAll & .htmlbody
.Display
End With
End Sub

Attach .jpg screenshot to Outlook mail

I created a form that contains an attachment field that screenshots are attached to in .jpg format.
I am trying to send emails from the form.
I would like to attach the screenshots to the email, (the one that is already attached on the form).
I tried using the .attachment.add me.attachmentfield. This is not attaching anything to the email.
Also I am using a combobox to select a person to send the email to, (this is stored in another table along with an email address). I am unable to populate the To box in the email with the email address of the individual selected.
Actually an Access attachment field is not an email attachment. Access doesn't have a build in email client, so you must use an email client library like CDO or the Outlook Object library:
Public Function SendEmail(strRecipients As String, strSubject As String, _
Optional strBody As String, Optional strFilePath As String, _
Optional strFileExtension As String) As String
On Error GoTo ProcError
Dim myObject As Object
Dim myItem As Object
Dim strFullPath As String
Dim strFileName As String
Dim strAttachPath As Variant
Dim intAttachments As Integer
Set myObject = CreateObject("Outlook.Application")
Set myItem = myObject.CreateItem(0)
With myItem
.Subject = strSubject
.To = strRecipients
If Len(Trim(strBody)) > 0 Then
.body = strBody
End If
If Len(Trim(strFileExtension)) = 0 Then
strFileExtension = "*.*"
End If
If Len(strFilePath) > 0 Then
strFullPath = strFilePath & "\" & strFileExtension
If Len(Trim(strFullPath)) > 0 Then 'An optional path was included
strFileName = Dir(strFullPath)
Do Until strFileName = ""
intAttachments = intAttachments + 1
strAttachPath = (strFilePath & "\" & strFileName)
.Attachments.add (strAttachPath)
' Debug.Print strAttachPath
strFileName = Dir()
Loop
End If
End If
.Send
SendEmail = "Message placed in outbox with " & intAttachments & " file attachment(s)."
End With
ExitProc:
Set myItem = Nothing
Set myObject = Nothing
Exit Function
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbCritical, "Error in SendMail Function..."
SendEmail = "A problem was encountered attempting to automate Outlook."
Resume ExitProc
End Function
Use Field.SaveToFile to dump the Access attachment to a temp file.

Userform variables to E-mail

I have a Userform which has 3 buttons on it and based on the click the respective text needs to be inserted in the body of the email, for this e-mail the To, CC, Subject, will be taken from Listview box in Sheet1 which inturn extracts the values stored in Sheet2 and paste it in To, CC, Subject of the email.
When i paste the code in the buttonclick () command the variables are not getting passed from the maincode to the userform code where it shows the To, CC and Subject as blanks.
Here's the code:
Sub Worksheet_Activate()
Dim rngCell As Range
ListView41.ListItems.Clear
For Each rngCell In Worksheets("MFRs Contacts").Range("A2:A400")
If Not rngCell = Empty Then
With ListView41.ListItems.Add(, , rngCell.Value)
.ListSubItems.Add , , rngCell.Offset(0, 1).Value
.ListSubItems.Add , , rngCell.Offset(0, 2).Value
End With
End If
Next rngCell
End Sub
Sub ListView41_DblClick()
Dim strName As String
Dim strEmail As String
Dim strEmail1 As String
Dim OutApp As Object
Dim OutMail As Object
Dim Singlepart As String
Dim SigString As String
Dim Signature As String
Dim strbody As String
Dim SigFilename
strName = ListView41.SelectedItem.Text
strEmail = ListView41.SelectedItem.ListSubItems(1).Text
strEmail1 = ListView41.SelectedItem.ListSubItems(2).Text
check = MsgBox("Send e-mail, To : " & strName & " - " & strEmail & "?" & vbNewLine & _
"CC : " & strEmail1, vbYesNo)
If check <> vbYes Then Exit Sub
Singlepart = MsgBox("For Single Part or Multiple Parts ? " & vbNewLine & vbNewLine & _
"Single Part = Yes" & vbNewLine & _
"Multiple Parts = No", vbYesNo)
If Singlepart = vbYes Then
' For Single Part Numbers
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"Ron's Excel Page" & _
"<br><br><B>Thank you</B>"
'Signature of User
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Rohith UTAS.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
Userform1.Show
'With Outlook
With OutMail
.Display
.To = strEmail
.CC = strEmail1
.BCC = ""
.Subject = strName & "_Request for Product Information"
.HTMLBody = strbody & vbNewLine & Signature
.Display 'or .Display if you want the user to view e-mail and send it manually
End With
Else
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you please help me on this.
Your variables you need to access on your form (I'm assuming strName, strEmail, and strEmail1) only have scope in Sub ListView41_DblClick(). If you need to use them in your form, you'll have to pass them as parameters (my preferred way to do it) or give them global scope.
A UserForm is a class, so you can give it properties like any other class - i.e. in UserForm1:
Private mEmail As String
Public Property Let Email(inputVal As String)
mEmail = inputVal
End Property
Public Property Get Email() As String
Email = mEmail
End Property
Then you would call it like any other object:
Dim nameless_form As UserForm1
Set nameless_form = New UserForm1
nameless_form.Email = strEmail
nameless_form.Show

Exporting rich text to outlook and keep formatting

I have a button in Access that opens Outlook, creating an appointment.
Private Sub addAppointEstimate_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
strSubject = Forms!frmMain.LastName 'more stuff to add
strBody = DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78") '& Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID)
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.RTFBody = StrConv(strBody, vbFromUnicode)
.Display
End With
End Sub
The problem is that I want to insert Rich text into the Body but it doesn't format correctly, as it shows all the HTML tags instead e.g:
<div><strong>example </strong><font color=red>text</font></div>
Is there a way I can send or convert the rich text to Outlook in a format it will recognise? (Maybe using the clipboard)
It seems many people have solution for Excel, but I am struggling to get them to work in Access:
HTML Text with tags to formatted text in an Excel cell
http://dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/
To pass RTF formatted string to outlook email body is simple as following
Function RTF2Outlook(strRTF as String) as boolean
Dim myOlApp, myOlItem
Dim arrFiles() As String, arrDesc() As String, i As Long
Set myOlApp = CreateObject("Outlook.Application")
Set myOlItem = myOlApp.CreateItem(olMailItem)
With myOlItem
.BodyFormat = olFormatRichText
.Body = StrConv(strRTF, vbFromUnicode) 'Convert RTF string to byte array
End With
Set myOlApp = Nothing
Set myOlItem = Nothing
End Function
The secret is not to use ".RTFBody" but just ".Body" and pass to it byte array as in the code above. It took me awhile to figure it out.
Thanks to Microsoft we always will have something to figure out.
You can use a little extra overhead to create a message with the formatted HTMLBody content, then copy the content to an Appointment item.
Start by creating a message and an appointment and populating them as desired. Put the body text in the message, skip the body in the appointment for now.
Dim objOutlook As Object
Dim objMyMsgItem As Object
Dim objMyApptItem As Object
Dim strSubject As String
strSubject = "Some text" 'Forms!frmMain.LastName 'more stuff to add
Set objOutlook = CreateObject("Outlook.Application")
Set objMyMsgItem = objOutlook.CreateItem(0) 'Message Item
With objMyMsgItem
.HTMLBody = "<div><strong>example </strong><font color=red>text</font></div>"
'DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78")
.Display
End With
Set objMyApptItem = objOutlook.CreateItem(1) 'Appointment Item
With objMyApptItem
.Subject = strSubject
.Display
End With
Then use the GetInspector property to interact with the body of each item via a Word editor, and copy the formatted text that way.
Dim MyMsgInspector As Object
Dim wdDoc_Msg As Object
Set MyMsgInspector = objMyMsgItem.GetInspector
Set wdDoc_Msg = MyMsgInspector.WordEditor
Dim MyApptInspector As Object
Dim wdDoc_Appt As Object
Set MyApptInspector = objMyApptItem.GetInspector
Set wdDoc_Appt = MyApptInspector.WordEditor
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText
This code is tested and works in Access 2013.
You are setting the plain text Body property. Set the HTMLBody property to a properly formatted HTML string.
I came up with a solution. I have just copied and pasted the entire sub, but the answer is in there I promise. I have also highlighted the important bits.
I works on my home machine, but not on the clients. So I cant use it, but if you can improve on it let me know.
Private Sub addAppointmentEst_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
On Error GoTo appointmentEstError
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
DoCmd.OpenForm "frmEditEstimate", , , , , acHidden '<------ OPEN FORMATTED TEXT IN A FORM
Forms!frmEditEstimate.SetFocus
Forms!frmEditEstimate!frmSubEstimateItems.Form.EstimateText.SetFocus
DoCmd.RunCommand acCmdCopy '<------ COPY FORMATTED TEXT
DoCmd.Close acForm, "frmEditEstimate", acSaveNo
End If
' If Not IsNull(Forms!frmMain.Title.Value) Then
' strSubject = strSubject & Forms!frmMain.Title.Value
' End If
If Not IsNull(Forms!frmMain.FirstName.Value) Then
strSubject = strSubject & Forms!frmMain.FirstName.Value
End If
If Not IsNull(Forms!frmMain.LastName.Value) Then
strSubject = strSubject & " " & Forms!frmMain.LastName.Value
End If
If Not IsNull(Forms!frmMain.Organisation.Value) Then
strSubject = strSubject & " (" & Forms!frmMain.Organisation.Value & ")"
End If
If Not IsNull(Forms!frmMain!frmSubTransaction.Form.Property.Value) Then
strSubject = strSubject & " - " & Forms!frmMain!frmSubTransaction.Form.Property.Value
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.Display
End With
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
Set objectOutlookBody = objOutlook.ActiveInspector.WordEditor
objOutLookApp.Body = vbCrLf & "Estimate ID: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID.Value & _
vbCrLf & "Estimate Date: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateDate.Value
objectOutlookBody.Application.Selection.Paste '<----- PASTE TEXT INTO APPOINTMENT
Forms!frmMain.EmptyValue.Value = " " '<----- EMPTY CLIPBOARD
Forms!frmMain.EmptyValue.SetFocus
DoCmd.RunCommand acCmdCopy
End If
Exit Sub
appointmentEstError:
MsgBox _
Prompt:="Failed create an appointment in Outlook, with the estimate attached", _
Buttons:=vbOKOnly + vbExclamation, _
Title:="Error"
End Sub
As in previous answer, this line is the key, it copies text, hyperlinks, pictures etc. without modifying clipboard content:
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText