Adding multiple attachments to a single email using outlook VBA - vba

EDIT
Sub CreateEmail(Subject As String, Body As String, ToSend As String, CCs As String, FilePathtoAdd As String)
Dim OlApp As Object
Dim OlMail As MailItem
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim Attachments() As String
Dim i As Integer
Set OlApp = Application
Set OlMail = OlApp.CreateItem(olMailItem)
OlMail.Recipients.Add ToSend
OlMail.Subject = Subject
OlMail.Body = Body
OlMail.SentOnBehalfOfName = "mailbox"
If FilePath1 <> "" Then
If FilePathtoAdd <> "" Then
Attachments = Split(FilePathtoAdd, ",")
For i = LBound(Attachments) To UBound(Attachments)
If Attachments(i) <> "" Then
OMail.Attachments.Add Trim(Attachments(i))
End If
Next i
End If
End If
OlMail.Display 'change this to OlMail.Send if you just want to send it without previewing it
End Sub
Sub EmailIt()
CreateEmail "This is Subject", "Body", "To", "CC", "C:\Users\b\Desktop\NFM\Export\0418 LSN " & Format(Date, "mm-dd-yy") & ".xls", "C:\Users\b\Desktop\NFM\Export\0418 Backorder " & Format(Date, "mm-dd-yy") & ".xls"
End Sub
I'm using the code below, in outlook vba, to create an email, attach a file, and send the email. It works fine, except I can't figure out how to add multiple attachments to a single email? Any help is greatly appreciated.
Sub CreateEmail(Subject As String, Body As String, ToSend As String, CCs As String, FilePathtoAdd As String)
'write the default Outlook contact name list to the active worksheet
Dim OlApp As Object
Dim OlMail As MailItem
Dim ToRecipient As Variant
Dim CcRecipient As Variant
'Set OlApp = CreateObject("Outlook.Application")
'Set OlMail = OlApp.CreateItem(olMailItem)
Set OlApp = Application
Set OlMail = OlApp.CreateItem(olMailItem)
'For Each ToRecipient In Array("mba.szabist#gmail.com", "mba.szabist#gmail.com", "mba.szabist#gmail.com")
'OlMail.Recipients.Add ToRecipient
OlMail.Recipients.Add ToSend
'Next ToRecipient
'fill in Subject field
OlMail.Subject = Subject
OlMail.Body = Body
OlMail.SentOnBehalfOfName = "email.com"
'Add the active workbook as an attachment
' OlMail.Attachments.Add "C:\Users\Ali\Desktop\Sentence Correction\Comparisons.pdf"
If FilePathtoAdd <> "" Then
OlMail.Attachments.Add FilePathtoAdd
End If
'Display the message
OlMail.Display 'change this to OlMail.Send if you just want to send it without previewing it
End Sub
Sub EmailIt()
CreateEmail "This is Subject", "Body", "email.com", " ", "C:\Users\b\Desktop\NFM\Export\0418 LSN " & Format(Date, "mm-dd-yy") & ".xls"
End Sub

You just need to do:
Olmail.attachments.add secondpath
If you put the attachment paths in a comma delimited string and pass it as "FilePathToAdd" then you can do this:
Dim Attachments() As String
Dim i As Integer
If FilePathToAdd <> "" Then
Attachments = Split(FilePathToAdd, ",")
For i = LBound(Attachments) To UBound(Attachments)
If Attachments(i) <> "" Then
OlMail.Attachments.Add Trim(Attachments(i))
End If
Next i
End If

The following lines from your code add the attachment:
'Add the active workbook as an attachment
' OlMail.Attachments.Add "C:\Users\Ali\Desktop\Sentence Correction\Comparisons.pdf"
If FilePathtoAdd <> "" Then
OlMail.Attachments.Add FilePathtoAdd
End If
You just need to call the Add method of the Attachment class as many times as you need to add attachments specifying different file paths.

Related

Exclude signature from attachment look up macro

I'm working on a macro which checks the attachment name against the subject name and the domain.
At the moment there's a couple of minor issues, I don't want the macro to recognise images in the signature as an attachment. Solutions I've seen include using an if statement to work out the size, so for example only check attachments over 5kb etc.
The other issue is, if there is no attachment at all, the macro falls over! I think I need another if statement in there at the end to do an item count but I'm not sure how that alters my conditions at the end of the macro!
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim outRecips As Outlook.Recipients
Dim outRecip As Outlook.Recipient
Dim outPropAcc As Outlook.PropertyAccessor
Dim strDomain As String
Dim lngPreDom As Long
Dim lngPostDom As Long
Dim strSubject As String
Dim objAttachments As Outlook.Attachments
Dim strAttachment As String
Dim Response As String
' set domain value
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set outRecips = Item.Recipients
For Each outRecip In outRecips
Set outPropAcc = outRecip.PropertyAccessor
strDomain = outPropAcc.GetProperty(PR_SMTP_ADDRESS)
strDomain = Split(strDomain, "#")(1)
lngPreDom = InStr(strDomain, "#")
lngPostDom = InStr(strDomain, ".")
strDomain = LCase(Mid(strDomain, lngPreDom + 1, lngPostDom - lngPreDom - 1))
Exit For
Next
' set subject value
strSubject = LCase(Item.Subject)
' set attachment name
Set objAttachments = Item.Attachments
strAttachment = LCase(objAttachments.Item(1).FileName)
' if external recipient, check email contents
If strDomain <> "exampleemail" _
Then
If InStr(strSubject, strDomain) = 0 _
Or InStr(strAttachment, strDomain) = 0 _
Or InStr(strAttachment, strSubject) = 0 _
Then
Response = "Attachment/Subject do not match Recipient(s)" & vbNewLine & "Send Anyway?"
If MsgBox(Response, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Recipients") = vbNo Then
Cancel = True
End If
End If
End If
End Sub
Use the Attachment.PropertyAccessor object to read the PR_ATTACHMENT_HIDDEN property (http://schemas.microsoft.com/mapi/proptag/0x7FFE000B); if it's true it's an embedded image (usually in signatures).

Download attachment (attachment not found)

I've got a code from here and I'm tweaking it for my need. My need is quite simple: I need it to download if it has the name of the Daily Tracker I'm keeping track of (as it changes daily with the Format(Now)). The problem is that it is not finding the attachment.
The code can find the email if I substitute the ElseIf to Next part for oOlItm.Display, but won't download the attachment.
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy")
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
For Each oOlItm In oOlInb.Items
If InStr(oOlItm.Subject, NewFilename)) <> 0 Then
ElseIf oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile (AttachmentPath)
Exit For
Next
Else
MsgBox "No attachments found"
End If
Exit For
Next
End Sub
The email:
This should work for you:
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For Each oOlItm In oOlResults
If oOlItm.attachments.Count > 0 Then
For Each oOlAtch In oOlItm.attachments
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next oOlItm
End Sub
'----------------------------------------------------------------------
' GetExt
'
' Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String
Dim mFSO As Object
Set mFSO = CreateObject("Scripting.FileSystemObject")
GetExt = mFSO.GetExtensionName(FileName)
End Function
Another way of doing it is from within Outlook:
Create a new folder in your Outlook Inbox and set a rule to move the email to this folder when it arrives. You can then write code to watch this folder and save the file as soon as it arrives.
Place this code within the ThisOutlookSession module in Outlook.
Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\TEMP\TestExcel\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _
.Folders.Item("Inbox") _
.Folders.Item("My Email For Processing").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment
Dim i As Integer
Dim sTmpFileName As String
Dim objFSO As Object
Dim sExt As String
If Item.Attachments.Count > 0 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
sExt = objFSO.GetExtensionName(olAtt.FileName)
If sExt = "xlsx" Then
sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx"
End If
Item.UnRead = False
olAtt.SaveAsFile FILE_PATH & sTmpFileName
DoEvents
Next
End If
Set olAtt = Nothing
MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker"
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
Create a new module in Outlook and put this code in there. This will create a messagebox that won't stop whatever you're doing.
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter
' to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT ‘cancel’ or the default button choice.
' Nigel Heffernan, 2006. This code is in the public domain.
' Uses late-binding: bad for performance and stability, useful for code portability
' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell
Dim objWshell As Object
Set objWshell = CreateObject("WScript.Shell")
MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)
Set objWshell = Nothing
End Function

How do I loop through a specific folder in outlook

What would be the VBA code for looping through a specific folder in outlook 2010 that is NOT the default inbox nor a subfolder of the inbox?
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = Please help me :-)
Thank you for any hint and help, greetings Ionic
Change
Set ns = Session.Application.GetNamespace("MAPI")
To
Set ns = Session.Application.GetNamespace("MAPI").PickFolder
This will prompt you to select the folder.
Here's a full routine that I wrote some time ago that may be of assistance, bear in mind this was written so that it could be run from Excel but should provide you with the syntax that you need:
Sub GetMail()
'// This sub is designed to be used with a blank worksheet. It will create the header
'// fields as required, and continue to populate the email data below the relevant header.
'// Declare required variables
'-------------------------------------------------------------
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'//Turn off screen updating
Application.ScreenUpdating = False
'//Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'//Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'//Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'//Get count of mail items
totalItems = olFolder.items.Count
mailCount = 0
'//Loop through mail items in folder
For Each loopControl In olFolder.items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'//Increase mailCount
mailCount = mailCount + 1
'//Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'//Get mail item
Set olMailItem = loopControl
'//Get Details
With olMailItem
strTo = .To
'//If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
strBody = .Body
End With
'//Place information into spreadsheet
'//import information starting from last blank row in column A
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
'//Check for previous replies by looking for "From:" in the body text
'//Check for the word "From:"
If InStr(0, strBody, "From:") > 0 Then
'//If exists, copy start of email body, up to the position of "From:"
.Offset(0, 3).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
Else
'//If doesn't exist, copy entire mail body
.Offset(0, 3).Value = strBody
End If
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
'//Release item from memory
Set olMailItem = Nothing
End If
'//Next Item
Next loopControl
'//Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'//Resume screen updating
Application.ScreenUpdating = True
'//reset status bar
Application.StatusBar = False
'//Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
Okay, I've found it myself.
Set folder = ns.GetDefaultFolder(olFolderInbox).Parent.Folders(NAME OF THE FOLDER)
Than you for your help guys !

How do you extract email addresses from the 'To' field in outlook?

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

Gmail like "Send and Archive" in Outlook. How to get to the "parent" email when replying

Responding to an email with the subject line "test", with this code...
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then
Debug.Print Item.Subject
Debug.Print Item.Parent
End If
End Sub
...returns this.
Inbox
RE: test
I'm looking to get to "test", which is the email being responded to so it can be automatically .Move(d) to an archive folder.
This would be better in Outlook 2010, I think. For earlier versions, I believe you want this code which is quoted directly from http://www.outlookcode.com/codedetail.aspx?id=1714
Function FindParentMessage(msg As Outlook.MailItem) _
As Outlook.MailItem
Dim strFind As String
Dim strIndex As String
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim itm As Outlook.MailItem
On Error Resume Next
strIndex = Left(msg.ConversationIndex, _
Len(msg.ConversationIndex) - 10)
Set fld = Application.Session.GetDefaultFolder(olFolderInbox)
strFind = "[ConversationTopic] = " & _
Chr(34) & msg.ConversationTopic & Chr(34)
Set itms = fld.Items.Restrict(strFind)
Debug.Print itms.Count
For Each itm In itms
If itm.ConversationIndex = strIndex Then
Debug.Print itm.To
Set FindParentMessage = itm
Exit For
End If
Next
Set fld = Nothing
Set itms = Nothing
Set itm = Nothing
End Function
Item.ConversationTopic
is the property you're looking for.