I'm create small VBA script for send Email with VBA.I'm create Dialog box for identify Recipients.It work well but it can get one Recipient.Like this :
This's my output.It show only one last Recipient.
This's my Code:
Sub cc_BCC()
Dim oMsg As Outlook.MailItem
Set oMsg = Outlook.Application.CreateItem(olMailItem)
Dim oDialog As Outlook.SelectNamesDialog
Set oDialog = Outlook.Application.Session.GetSelectNamesDialog
Dim oAL As Outlook.AddressList
Dim oContacts As Outlook.Folder
Dim cEI As String
Dim c As Outlook.AddressEntry
Dim olRecipient As Outlook.Recipient
Set oContacts = _
Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
For Each oAL In Outlook.Application.Session.AddressLists
If oAL.AddressListType = olOutlookAddressList Then
If oAL.GetContactsFolder.EntryID = _
oContacts.EntryID Then
Exit For
End If
End If
Next
With oDialog
.Caption = "Select Customer Contact"
.ToLabel = "Customer C&ontact"
.NumberOfRecipientSelectors = olShowTo
.InitialAddressList = oAL
.AllowMultipleSelection = True
.Recipients = oMsg.Recipients
If .Display Then
'Recipients Resolved
For Each olRecipient In .Recipients
cEI = olRecipient.EntryID 'entry id of selected contact
Set c = Outlook.Application.Session.GetAddressEntryFromID(cEI)
Worksheets("Dialog").Range("A15") = c.GetContact.FirstName & " " & c.GetContact.LastName
Next
End If
End With
End Sub
And I need this output.Like this:
How can I fix this problem?
Firstly, do not hardcode the cell name ("A15"). Secondly, do not call GetAddressEntryFromID - just use Recipient.AddressEntry. Thirdly, do not assume GetContact will return a non-null value, it only works if the item comes from your Contacts folder, it will not work for the GAL entries.
For i = 1 to .Recipients.Count
set olRecipient = .Recipients(i)
Worksheets("Dialog").Range("A" & i) = olRecipient.name
Next
Im trying to write condition and depending on which recipient has an email forward it to another email. After searching in web I found following but its not work for me:
Public Sub ConvertMeetingToEmail(ActiveFolder, Inbox As String)
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim Subfolder As Outlook.Folder
Dim Item As Object
Dim myMtg As Outlook.MeetingItem
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders(ActiveFolder)
Set Folders = myFolder.Folders
Set Subfolder = Folders.Item(Inbox)
For Each Item In Subfolder.Items
If Item.MessageClass = "IPM.Schedule.Meeting.Request" Then
Set Msg = Item
Set recips = Msg.Recipients
For Each recip In recips
If (recip = "example#mail.domail" _
Or recip = "example1#mail.domail" _
Or recip = "example2#mail.domail" _
Or recip = "example3#mail.domail" _
Or recip = "example4#mail.domail") Then
objMsg.To = "example6#mail.domail"
objMsg.CC = recip
objMsg.Subject = Msg.Subject
objMsg.Body = Msg.Body
objMsg.Send
Endif
Next
End If
Next
End Sub
Recipients collection returns Recipient objects, not strings, so your code should be checking the recip.Address property. It is also a good idea to use case insensitive string comparison:
If ((StrComp(recip.Address, "example#mail.domail", 1) = 0) _
...
I'm reading Outlook Inbox and Sent folder emails for a given address and populating an Access table. My routine isn't picking up the "Reply" emails. I assumed they would be in the sent folder. I don't have any subfolders at this time. Any thoughts on what I'm missing or don't understand? This is my first venture into reading Outlook data.
Sub GetFromInbox(strInboxSent As String, strForAddress As String)
Dim olFolderInboxSent As Integer
Select Case strInboxSent
Case "InBox"
olFolderInboxSent = 6 '6 = InBox, Sent = 5
Case "Sent"
olFolderInboxSent = 5
End Select
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInboxSent)
GetFromFolder oRootFldr, strForAddress, olFolderInboxSent
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object, strForAddress As String, intInboxSent As Integer)
'Load Worktable with sent emails
Dim cmd As ADODB.Command
Dim rst As ADODB.Recordset
Set cmd = New ADODB.Command
cmd.ActiveConnection = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.LockType = adLockOptimistic
cmd.CommandText = "Select * From wtblEmails"
rst.Open cmd
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
Debug.Print TypeName(oItem)
If TypeName(oItem) = "MailItem" Then
With oItem
Select Case intInboxSent
Case 6
If .SenderEmailAddress = strForAddress Then
'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
rst.AddNew
rst!weDate = .CreationTime
rst!weRcvdSent = "R"
rst!weWith = .SenderEmailAddress
rst!weSubject = .Subject
rst!weBody = .Body
rst!weid = .EntryID
rst.Update
End If
Case 5
If .To = strForAddress Then
'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
rst.AddNew
rst!weDate = .CreationTime
rst!weRcvdSent = "S"
rst!weWith = .To
rst!weSubject = .Subject
rst!weBody = .Body
rst!weid = .EntryID
rst.Update
End If
End Select
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr, strForAddress, intInboxSent
Next
End Sub
Here is what I found that works. The list of recipient address for a sent email are found here. For each email item, I call this function to see if the address I'm looking for was in the list of recipients.
Public Function fncWasMailSentTo(mail As Outlook.MailItem, strAddress As String) As Boolean
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
fncWasMailSentTo = False
For Each recip In recips
Set pa = recip.PropertyAccessor
'Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
If pa.GetProperty(PR_SMTP_ADDRESS) = strAddress Then
fncWasMailSentTo = True
Exit For
End If
Next
End Function
I want to change recipient's email address when sending a message. I don't know if I should work with item.to or rec.addressentry or myrecipient.
I want it to work like when you enter example#mail.com then it will send it to example2#mail.com, it can rewrite while pressing send button or just send to the example2.
I want to to start the macro at the startup so it should be after startup event and I guess it should be itemsend event.
I tried these:
not working
'Item = MailItem
If Item.To = "example#mail.com" Then
Item.To = "example2#mail.com"
does not close the message window
If Item.Class <> olMail Then Exit Sub
Dim newEm As String
Dim Rec As Recipient
Dim myItem As Outlook.MailItem
Dim myRecipient As Outlook.Recipient
Set myItem = Application.CreateItem(olMailItem)
myItem.Body = Item.Body
myItem.HTMLBody = Item.HTMLBody
myItem.Subject = Item.Subject
Cancel = True
If InStr(1, Rec.AddressEntry, "example#mail.com", vbTextCompare) Then
newEm = "example2#mail.com"
End If
Set myRecipient = myItem.Recipients.Add(newEm)
myRecipient.Type = Rec.Type
Next
myItem.Send
End Sub
Try this:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.To = ChangeSMTPRecipient(Item, "example#mail.com", "example2#mail.com")
End Sub
Function ChangeSMTPRecipient(mail As Outlook.MailItem, FromSMTP, ToSMTP) As String
On Error Resume Next
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"
ChangeSMTPRecipient = ""
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
RecipNew = pa.GetProperty(PR_SMTP_ADDRESS)
If RecipNew = FromSMTP Then RecipNew = ToSMTP
ChangeSMTPRecipient = ChangeSMTPRecipient & IIf(ChangeSMTPRecipient = "", "", "; ") & RecipNew
Next
On Error GoTo 0
End Function
I have been using VBA to some degree, using this code:
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\mydocuments\emailss.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
Email = Mailobject.To
a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub
However this gives output as the names of the email addresses and not the actual email address with the "something#this.domain".
Is there an attributte of the mailobject that will allow the email addresses and not the names to be written from the 'To' Textbox.
Thanks
Check out the Recipients collection object for your mail item, which should allow you to get the address: http://msdn.microsoft.com/en-us/library/office/ff868695.aspx
Update 8/10/2017
Looking back on this answer, I realized I did a bad thing by only linking somewhere and not providing a bit more info.
Here's a code snippet from that MSDN link above, showing how the Recipients object can be used to get an email address (snippet is in VBA):
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
It looks like, for email addresses outside of your organization, the SMTP address is hidden in emailObject.Recipients(i).Address, though it doesn't seem to allow you to distinguish To/CC/BCC.
The Microsoft code was giving me an error, and some investigating reveals that the schema page is no longer available. I wanted a semicolon-delaminated list of email addresses that were either in my Exchange organization or outside of it. Combining it with another S/O answer to convert inner-company email display names to SMTP names, this does the trick.
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
If the email is inside your organization, you need to convert it to an SMTP email address. I found this function from another StackOverflow answer helpful:
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
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
The answers above did not work for me. I think they only work when the recipient is in the address book. The following code is also to able to lookup email addresses from outside the organisation. Additionally it makes a distinction between to/cc/bcc
Dim olRecipient As Outlook.Recipient
Dim strToEmails, strCcEmails, strBCcEmails As String
For Each olRecipient In item.Recipients
Dim mail As String
If olRecipient.AddressEntry Is Nothing Then
mail = olRecipient.Address
ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
mail = olRecipient.Address
Else
mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Debug.Print "resolved", olRecipient.Name, mail
If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
strToEmails = strToEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
strCcEmails = strCcEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
strBCcEmails = strBCcEmails + mail & ";"
End If
Next
Debug.Print strToEmails
Debug.Print strCcEmails
Debug.Print strBCcEmails
Another code alternative (based initially on the answer by #andreasDL) which should be able to be used...
Pass in a MailItem to the EmailAddressInfo function to get an array of the Sender, To and CC fields from the message
Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
'BCC addresses are not included within received messages
Function PrintEmailAddresses(olItem As MailItem)
If olItem.Class <> olMail Then Exit Function
Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
Debug.Print "Sender: " & Arr(olOriginator)
Debug.Print "To Address: " & Arr(olTo)
Debug.Print "CC Address: " & Arr(olCC)
End Function
Private Function EmailAddressInfo(olItem As MailItem) As Variant
If olItem.Class <> olMail Then Exit Function
On Error GoTo ExitFunction
Dim olRecipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim olEDL As Outlook.ExchangeDistributionList
Dim ToAddress, CCAddress, Originator, email As String
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
End Select
End With
For Each olRecipient In olItem.Recipients
With olRecipient
Select Case .AddressEntry.AddressEntryUserType
Case olSmtpAddressEntry 'OlAddressEntryUserType.
email = .Address
Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
Set olEDL = .AddressEntry.GetExchangeDistributionList
email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
Case Else
Set olEU = .AddressEntry.GetExchangeUser
email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
End Select
If email <> "" Then
Select Case .Type
Case olTo: ToAddress = ToAddress & email & ";"
Case olCC: CCAddress = CCAddress & email & ";"
End Select
End If
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
This is what worked for me with Outlook 2019. Use your internal domain name(s). Might need some tweaking yet - not heavily tested. Place code in the ThisOutlookSession module. (Updated to handle Exchange distribution lists 7/31/20.)
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim OutRec As Outlook.Recipient
Dim OutTI As Outlook.TaskItem
Dim i As Long
Dim j As Long
Dim xOKCancel As Integer
Dim sMsg As String
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim sDomains As String
Dim sTemp As String
On Error Resume Next
If Item.Class <> olMail Then GoTo ExitCode
sDomains = "#test1.com #test2.com"
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
'Loop through email recipients to get email addresses
For i = xRecipients.Count To 1 Step -1
'If we have a text address entry in the email
If InStr(xRecipients.Item(i).AddressEntry, "#") > 0 Then
sTemp = xRecipients.Item(i).AddressEntry
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Else
Select Case xRecipients.Item(i).AddressEntry.DisplayType
Case Is = olDistList
Set oMembers = xRecipients.Item(i).AddressEntry.Members
For j = oMembers.Count To 1 Step -1
Set oMember = oMembers.Item(j)
sTemp = oMember.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Set oMember = Nothing
Next j
Set oMembers = Nothing
Case Is = olUser
Set OutTI = Application.CreateItem(3)
OutTI.Assign
Set OutRec = OutTI.Recipients.Add(xRecipients.Item(i).AddressEntry)
OutRec.Resolve
If OutRec.Resolved Then
sTemp = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
End If
Set OutTI = Nothing
Set OutRec = Nothing
Case Else
MsgBox "Unaccomodated AddressEntry.DisplayType."
GoTo ExitCode
End Select
End If
Next i
'Display user message
If Len(sMsg) > 0 Then
sMsg = "This email is addressed to the following external Recipients:" & vbCrLf & vbCrLf & sMsg
xOKCancel = MsgBox(sMsg, vbOKCancel + vbQuestion, "Warning")
If xOKCancel = vbCancel Then Cancel = True
End If
End Sub