If I select 4 emails in outlook and run the code below, it should create 4 new emails that has different first name on the email body. But the code only gets the first name on Email 1 and also displays it to the 2nd to 4th.
Example:
Email 1: First Name Person1
Email 2: First Name Person2
Email 3: First Name Person3
Email 4: First Name Person4
The generated email result should be:
Email 1: Person1
Email 2: Person2
Email 3: Person3
Email 4: Person4
..
Sub FindName()
Dim olMail As Outlook.MailItem
Dim Selection As Selection
Dim obj As Object
Set olMail = Application.ActiveExplorer().Selection(1)
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
Set objMsg = Application.CreateItem(olMailItem)
Dim rxp4 As New RegExp, m4 As Match, c4 As MatchCollection, FName As String
rxp4.pattern = "First Name\s*(\s*(\w.*\b))"
rxp4.Global = True
Set c4 = rxp4.Execute(olMail.Body)
For Each m4 In c4
FName = m4.SubMatches(0) + " "
Next
'--------------------------
With objMsg
.To = "test#mail.com"
.Subject = obj.Subject
'.Body = obj.Body
.HTMLBody = _
"<HTML><BODY>" & _
"<div style='font-size:10pt;font-family:Verdana'>" & _
"<table style='font-size:10pt;font-family:Verdana'>" & _
"<tbody>" & _
"<tr class='blue'><td>" + FName & "</td></tr>" & _
"<tbody>" & _
"</table>" & _
"</div>" & _
"</BODY></HTML>"
.Display
End With
'---------------------------
Next
End Sub
Partial answer - I'm not familiar with RegEx but some changes I'd make in first half of your code
Sub FindName()
Dim olMail As Outlook.MailItem
Dim Selection As Selection
Dim obj As Object
' Added or moved the following
Dim rxp4 As New RegExp, m4 As Match, c4 As MatchCollection, FName As String
Dim Ptr As Integer
' End of Additions
'Set olMail = Application.ActiveExplorer().Selection(1)
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
' Added the following
Ptr = Ptr + 1
Set olMail = Application.ActiveExplorer().Selection(Ptr)
' End of Aadditions
Set objMsg = Application.CreateItem(olMailItem)
'Dim rxp4 As New RegExp, m4 As Match, c4 As MatchCollection, FName As String
rxp4.Pattern = "First Name\s*(\s*(\w.*\b))"
rxp4.Global = True
Related
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).
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
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
My VBA code loops through Column "I" with people's names and creates a list of emails. In email body there's a list of rows for each person from columns B, C, G, I. Pretty straightforward, however I encounter an issue with the latter. It only takes the first row for each person, i.e. doesn't loop through the list to get all of the rows for one recipient.
I have a feeling this somehow stops it from looping further:
If InStr(1, PriorRecipients, EmailAddr) <> 0 Then
GoTo NextRecipient
End If
But not sure how to implement a second loop??
Full code:
Sub SendEmail2()
Dim OutlookApp
Dim MItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String
Dim Projects As String
Dim ProjectsMsg As String
Dim bSendMail As Boolean
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(0)
'Loop through the rows
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" And _
(Cells(cell.Row, "L").Value) = "No" And (Cells(cell.Row, "K").Value) <> "Yes" Then
'first build email address
EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "#company.com"
'then check if it is in Recipient List build, if not, add it, otherwise ignore
If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr
Projects = vbCrLf & "Document: " & Cells(cell.Row, "B").Value & "; " & Cells(cell.Row, "C").Value & "; " & "Rev " & Cells(cell.Row, "G").Value & "; " & Cells(cell.Row, "I").Value
If InStr(1, ProjectsMsg, Projects) = 0 Then ProjectsMsg = ProjectsMsg & Projects & vbCrLf
If InStr(1, Recipient, cell.Offset(1).Value) <> 0 Then
bSendMail = True
Recipient = Recipient & ";" & cell.Offset(1)
Else
bSendMail = False
End If
End If
Next
Msg = "You have the following outstanding documents to be reviewed at: "& ProjectsMsg
Subj = "Outstanding Documents to be Reviewed"
'Create Mail Item and view before sending
If bSendMail Then Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = Recipient 'full recipient list
.Subject = Subj
.Body = Msg
.display
End With
End Sub
Change this block of code:
If InStr(1, PriorRecipients, EmailAddr) <> 0 Then
GoTo NextRecipient
End If
PriorRecipients = PriorRecipients & ";" & EmailAddr
To this
If InStr(1, PriorRecipients, EmailAddr) = 0 Then
PriorRecipients = PriorRecipients & ";" & EmailAddr
End If
'checks if it's the last email for that unique person and if so,
`it's done looping rows for that email and the email is good to send
If Instr(1, PriorRecipients, cell.Offset(1).Value) <> 0 Then
Dim bSendMail as Boolean
bSendMail = True
PriorRecipients = PriorRecipients & ";" & cell.Offset(1)
Else
bSendMail = False
End If
If bSendMail Then
Set MItem = OutlookApp.CreateItem(olMailItem)
' rest of code to send mail ...
End If
I am trying to automate sending emails with multiple lines and paragraphs through excel using VBA. Here is the code I have so far:
Sub Send_Email()
Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String
Dim Mail_Object, Mail_Single As Variant
Email_Subject = "test"
Email_Send_From = "email"
Email_Cc = ""
Email_Bcc = ""
Dim r As Range, cell As Range, mynumber As Long
Dim i As Long
Set r = Range("K2:K300")
i = 2
For Each cell In r
If Cells(i, "K").Value = "" Then
Else
Email_Send_To = Worksheets("Sheet1").Cells(i,"K").Value
Email_Body = "test from outlook excel"
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.send
End With
End If
i = i + 1
Next
On Error GoTo debugs
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End Sub
However I'm not sure how to make the body of the email include line breaks and split up paragraphs rather than just having one block of text.
Use VBNewLine for a new line character.
Dim A As String: A = "Line A"
Dim B As String: B = "Line B"
Debug.print(A & VbNewLine & B)
Output:
Line A
Line B