I am trying to insert a list of email addresses from Excel into a contact group in Outlook.
I found Excel VBA code online. It uses early binding. It is not an option to force the user to go into Tools-> References -> Outlook, when they open the file.
I need to transform the code from early to late binding.
Questions:
I understand that I need to change Outlook.Application to
CreateObject('Outlook.Application') and that I can access
olFolderContacts with the number 10 instead. See code below.
I can't figure out how to access the remaining items such as
CreateItem(olDistributionListItem).
Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "PlaceHolder_VBA"
i = 0
Do While Range("vba_email_outlook").Offset(i, 0).Value <> "":
strName = Range("vba_name_outlook").Offset(i, 0).Value
strEmail = Range("vba_email_outlook").Offset(i, 0).Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Outlook.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
i = i + 1
Loop
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
End Sub
Declare object variables as generic Object
Dim objContactsFolder As Object
Determine number values of constants. With early binding, these values can be seen when hovering over constant or in VBA immediate window: ?olMailItem. Then reference number in place of constant or leave constants referenced as they are and declare them as constants with Const statements. Const olMailItem = 0
olFolderContacts = 10
olMailItem = 0
olDistributionListItem = 7
I am not an expert but this code allows you to add the reference when you run the VBA script, but it will mean that if it errors out the code quits running you will not be able to debug.
On Error Resume Next ''' If reference already exist this would cause an error
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB") ''' Might have to change file path
On Error GoTo 0
Related
Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"
the code below creates a recurring Outlook appointment and another Outlook appointment through Excel and VBA. i'm trying to send the appointment to a different inbox, but i keep getting the "Run-time Error 287: Application-defined or object-defined error" at the line "OutlookAppt.Recipients.Add ("XXXXXX#company-company.com")". the code works, except when i add this line, so i'm wondering why.
please let me know if you have any ideas as to how to fix this.
thank you a bunch in advance!
Sub CompleteReminders()
Dim rows
Dim sDate As Date, newFU As Date, newDate As Date, iDate As Date, generalDate As Date
Dim iValue As Integer
Dim iteration As Integer
Dim LastRow As Long
Dim i As Long
Dim x As Integer
Dim xRg As Range
Dim myNamespace As Object
Dim objfolder As Outlook.Folder
Dim OutlookAppt As Outlook.AppointmentItem
Dim OutlookAppt2 As Outlook.AppointmentItem
Dim myRecurrPatt As Outlook.RecurrencePattern
Const olFolderCalendar = 9
Const olAppointment = 26
Dim n As Integer
Set OutApp = GetObject(, "Outlook.Application")
If ErrL <> 0 Then
Set OutApp = CreateObject("Outlook.Application")
End If
Set myNamespace = OutApp.GetNamespace("MAPI")
Set objfolder = myNamespace.PickFolder 'Sets folder where appt will be created
Set xRg = Range("B6:D6")
Set OutlookAppt = OutApp.CreateItem(1)
OutlookAppt.Duration = 5
Set myRecurrPatt = OutlookAppt.GetRecurrencePattern
With myRecurrPatt
.PatternStartDate = Range("C1").Value
.RecurrenceType = olRecursMonthNth
.Interval = Range("C3").Value
.PatternEndDate = dateEnd
.StartTime = #5:00:00 PM#
.EndTime = #5:05:00 PM#
End With
OutlookAppt.Subject = xRg.Cells(1, 1).Value
If xRg.Cells(1, 2).Value > 0 Then
OutlookAppt.ReminderSet = True
OutlookAppt.ReminderMinutesBeforeStart = xRg.Cells(4, 6).Value
Else
OutlookAppt.ReminderSet = False
End If
OutlookAppt.Body = xRg.Cells(1, 3).Value
OutlookAppt.BusyStatus = olFree
OutlookAppt.Recipients.Add ("XXXXXX#company-company.com")
OutlookAppt.Save
Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)
End Sub
If your code is running unattended, make sure the security prompt is not getting in the way. Make sure antivirus app and its definitions are up-to-date.
Also try to replace the problematic line line with
OutlookAppt.RequiredAttendees = "XXXXXX#company-company.com"
For the RequiredAttendees property, only reading is blocked, but not setting.
In some really quick testing, I was able to get the line to work by setting the object (recipients are objects):
Dim requiredRecipient as Outlook.Recipient
Set requiredRecipient = OutlookAppt.Recipients.Add ("XXXXXX#company-company.com")
requiredRecipient.Type = olRequired
Docs for reference: https://learn.microsoft.com/en-us/office/vba/api/outlook.recipients
Get rid of () when calling Recipients.Add:
OutlookAppt.Recipients.Add "XXXXXX#company-company.com"
or change it to
set Recip = OutlookAppt.Recipients.Add ("XXXXXX#company-company.com")
() in VB are only used when calling a function, but not a sub.
Consider using the AppointmentItem.RequiredAttendees property instead. Also you may find the AppointmentItem.OptionalAttendees property helpful which returns or sets a string representing the display string of optional attendees names for the appointment. This is a semicolon-delimited string of required attendee names for the meeting appointment.
In case of using the Recipients property for meetings you need to use the OlMeetingRecipientType enumeration.
OutlookAppt.Recipients.Add "XXXXXX#company-company.com"
I have code which adds contacts from a worksheet to my Outlook contacts. Each Contact is on a separate line and has 5 columns with First Name, Last name, Email Address, Company and Mobilephone Number.
How do I add only those lines from the worksheet, which aren't in my contacts, so it doesn't create duplicates?
Sub ExcelWorksheetDataAddToOutlookContacts3()
Dim oApplOutlook As Object
Dim oNsOutlook As Object
Dim oCFolder As Object
Dim oDelFolder As Object
Dim oCItem As Object
Dim oDelItems As Object
Dim lLastRow As Long, i As Long, n As Long, c As Long
'determine last data row in the worksheet:
lLastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'Create a new instance of the Outlook application,
' if an existing Outlook object is not available.
'Set the Application object as follows:
On Error Resume Next
Set oApplOutlook = GetObject(, "Outlook.Application")
'if an instance of an existing Outlook object is not available,
' an error will occur (Err.Number = 0 means no error):
If Err.Number <> 0 Then
Set oApplOutlook = CreateObject("Outlook.Application")
End If
'disable error handling:
On Error GoTo 0
'use the GetNameSpace method to instantiate
' (ie. create an instance) a NameSpace object variable,
' to access existing Outlook items.
'Set the NameSpace object as follows:
Set oNsOutlook = oApplOutlook.GetNamespace("MAPI")
'----------------------------
'Empty the Deleted Items folder in Outlook so that
' when you quit the Outlook application you bypass the prompt:
' Are you sure you want to permanently delete all the items
' and subfolders in the "Deleted Items" folder?
'set the default Deleted Items folder:
'The numerical value of olFolderDeletedItems is 3.
'The following code has replaced the Outlook's built-in
' constant olFolderDeletedItems by its numerical value 3.
Set oDelFolder = oNsOutlook.GetDefaultFolder(3)
'set the items collection:
Set oDelItems = oDelFolder.Items
'determine number of items in the collection:
c = oDelItems.Count
'start deleting from the last item:
For n = c To 1 Step -1
oDelItems(n).Delete
Next n
'----------------------------
'set reference to the default Contact Items folder:
'The numerical value of olFolderContacts is 10.
'The following code has replaced the Outlook's built-in
' constant olFolderContacts by its numerical value 10.
Set oCFolder = oNsOutlook.GetDefaultFolder(10)
'post each row's data on a separate contact item form:
For i = 2 To lLastRow
'Using the Items.Add Method to create
' a new Outlook contact item in the default Contacts folder.
Set oCItem = oCFolder.Items.Add
'display the new contact item form:
oCItem.Display
'set properties of the new contact item:
With oCItem
.firstName = Sheets("Sheet1").Cells(i, 1)
.LastName = Sheets("Sheet1").Cells(i, 2)
.Email1Address = Sheets("Sheet1").Cells(i, 3)
.CompanyName = Sheets("Sheet1").Cells(i, 4)
.MobileTelephoneNumber = Sheets("Sheet1").Cells(i, 5)
End With
'close the new contact item form after saving:
'The numerical value of olSave is 0.
'The following code has replaced the Outlook's built-in
' constant olSave by its numerical value 0.
oCItem.Close 0
Next i
'quit the Oulook application:
oApplOutlook.Quit
'clear the variables:
Set oApplOutlook = Nothing
Set oNsOutlook = Nothing
Set oCFolder = Nothing
Set oDelFolder = Nothing
Set oCItem = Nothing
Set oDelItems = Nothing
MsgBox "Successfully Exported Worksheet Data to the Default Outlook Contacts Folder."
End Sub
Is this what you are trying? Here is a very basic fuction which uses Outlook Items.Find property to check if the email address exists in the address book.
Option Explicit
Dim OutApp As Object
Dim OutNs As Object
Dim OutFolder As Object
Dim OutItems As Object
Const olFolderContacts As Integer = 10
Sub Sample()
Set OutApp = CreateObject("Outlook.Application")
Set OutNs = OutApp.GetNameSpace("MAPI")
Set OutFolder = OutNs.GetDefaultFolder(olFolderContacts)
Set OutItems = OutFolder.items
Dim EmailToFind As String
'~~> Change email here
EmailToFind = "Sid#Sid.Com"
MsgBox DoesContactExists(EmailToFind)
End Sub
'~~> Function to check if the email exists
Private Function DoesContactExists(EmailAddress As String) As Boolean
Dim olContact As Object
On Error Resume Next
Set olContact = OutItems.Find("[Email1Address] = '" & name & "'")
On Error GoTo 0
If Not olContact Is Nothing Then DoesContactExists = True
End Function
I am trying to search Outlook for the most recent email with "Blue Recruit Req Data" in the Subject line.
There will be additional words in the subject line.
When an email is found I need to verify that it has an attachment.
I want to store the subject & the received date in variables and compare them to previous subject & date stored in the Excel file running the macro.
If the subject lines don't match & the date of the email is after the date last stored in the Excel file, then I want to save that attachment in a folder.
It is not finding emails that contain "Blue Recruit Req Data" in the subject.
Sub CheckEmail_BlueRecruit()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim olAp As Object, olns As Object, olInb As Object
Dim olItm As Object, olAtch As Object, olMail As Object
'Outlook Variables for email
Dim sSubj As String, dtRecvd As String
Dim oldSubj As String, olddtRecvd As String
Sheets("Job Mapping").Visible = True
Sheets("CC Mapping").Visible = True
Sheets("Site Mapping").Visible = True
Sheets("Historical Blue Recruit Data").Visible = True
Sheets("Historical HRT Data").Visible = False
Sheets("Combined Attrition Data").Visible = True
Sheets.Add Before:=Sheets(1)
'Designate ECP Facilities Model file as FNAME
myPath = ThisWorkbook.Path
MainWorkbook = ThisWorkbook.Name
Range("A1").Select
ActiveCell.FormulaR1C1 = myPath
'designate file path for Attrition Files
FacModPath = Cells(1, 1).Value
Sheets(1).Delete
'Get Outlook Instance
Set olAp = GetObject(, "Outlook.application")
Set olns = olAp.GetNamespace("MAPI")
Set olInb = olns.GetDefaultFolder(6)
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
'Chec if there are any matching emails
If Not (olMail Is Nothing) Then
For Each olItm In olMail
If myItem.Attachments.Count <> 0 Then
dtRecvd = olItm.ReceivedTime
sSubj = olItm.Subject
oldSubj = Sheets("CC Mapping").Range("M2").Value
olddtRecvd = Sheets("CC Mapping").Range("M3").Value
If sSubj = oldSubj Or dtRecvd <= olddtRecvd Then
MsgBox "No new Blue Recruit data files to load."
Exit Sub
Else
Range("M2").Select
ActiveCell.FormulaR1C1 = sSubj
Range("M3").Select
ActiveCell.FormulaR1C1 = dtRecvd
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".xlsx") Then
I = I + 1
myAttachment.SaveAs Filename:=FacModPath & "\" & myAttachment.DisplayName
Exit For
Else
MsgBox "No attachment found."
Exit For
End If
Next
End If
End If
Next
Else
MsgBox "No emails found."
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
A separate, but related question. I want to search for emails that are in the Outlook Archive folder, or even a subfolder of Inbox. Do I need to format this line of code any differently?
Set olInb = olns.GetDefaultFolder(6)
Of course, iterating over all items in a folder is not really a good and right idea. You need to use the Restrict or Find/FindNext methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
In the code posted above I've noticed the following line:
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
Be aware, the Restrict methods return an instance of the Items class which contains a collection of items that correspond to your condition, not a single item as you could think. For example:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, I'd change the filter string to include entries that may contain the passed substring:
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & wordsInSubject & " %'"
To get items ordered, i.e. start from the recent or oldest ones you need to sort the collection by using the Sort methods of the Items class:
Items.Sort("[ReceivedTime]")
Finally, you may also find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about the AdvancedSearch method and find the sample code in the Advanced search in Outlook programmatically: C#, VB.NET article.
I have refactored some of your code so you can take advantage of calling procedures and organize your logic.
I didn't include all of your code though, but as I can see, you have enough knowledge to make it work.
A couple of suggestions:
1- Use option explicit at the top of your modules
2- Try to define your variables to something meaningful (use names anybody can understand)
3- Try to indent your code consistently (you could use RubberDuck
Before pasting your code:
Use early binding to set the reference to Outlook object library and take advantage of intellisense and other benefits
1) Click on tools | References
2) Check the Microsoft Outlook XXX Object Library
Here is the refactored code:
Execute it using F8 key and adjust it to fit your needs
Public Sub CheckEmail_BlueRecruit()
' Declare objects
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim outlookFolder As Outlook.MAPIFolder
' Declare other variables
Dim filterKeywords As String
Dim filter As String
' Init objects
Set outlookApp = New Outlook.Application
Set outlookNamespace = Outlook.GetNamespace("MAPI")
Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
' Init other variables
filterKeywords = "financial"
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"
' Loop through folders
LoopFolders outlookFolder, filter
End Sub
Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
' DeclareObjects
Dim outlookSubFolder As Outlook.MAPIFolder
Dim outlookMail As Outlook.MailItem
ProcessFolder outlookFolder, filter
If outlookFolder.Folders.Count > 0 Then
For Each outlookSubFolder In outlookFolder.Folders
LoopFolders outlookSubFolder, filter
Next
End If
End Sub
Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
Dim outlookItems As Outlook.Items
Dim outlookMail As Outlook.MailItem
' Filter folder
Set outlookItems = outlookFolder.Items.Restrict(filter)
If Not outlookItems Is Nothing Then
For Each outlookMail In outlookItems
If outlookMail.Attachments.Count <> 0 Then
Debug.Print outlookMail.Subject
End If
Next outlookMail
End If
End Sub
Let me know if it works and you need any more help
I am trying to extract the email address from each individual undeliverables email body.
The email body would be like:
----------------------------Email----------------------------
Delivery has failed to these recipients or groups:
XXXX#XXXXXX.XXX (XXXX#XXXXXX.XXX)
...no need info...
To: XXXX#XXXXXX.XXX
...no need info...
----------------------------Email-----------------------------
I came up with below code:
Sub Test()
Dim myFolder As MAPIFolder
Dim Item As Outlook.MailItem 'MailItem
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Lines() As String
Dim i As Integer, x As Integer, P As Integer
Dim myItem As Variant
Dim subjectOfEmail As String
Dim bodyOfEmail As String
'Try access to excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
If xlApp Is Nothing Then
MsgBox "Excel is not accessable"
Exit Sub
End If
End If
On Error GoTo 0
'Add a new workbook
Set xlWB = xlApp.Workbooks.Add
xlApp.Application.Visible = True
Set xlSheet = xlWB.ActiveSheet
Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each myItem In myFolder.Items
subjectOfEmail = myItem.Subject
bodyOfEmail = myItem.Body
'Search for Undeliverable email
If bodyOfEmail Like "*Delivery*" & "*failed*" And indexOfEmail Like "*Undeliverable*" Then
x = x + 1
'Extract email address from email body
Lines = Split(myItem.Body, vbCrLf)
For i = 0 To UBound(Lines)
P = InStr(1, Lines(i), "#", vbTextCompare)
Q = InStr(1, Lines(i), "(", vbTextCompare)
If P > 0 Then
xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) 'extract the email address
Exit For
End If
Next
End If
Next
End Sub
It worked on my test Email Inbox, which opened an Excel sheet and listed every particular email address within the target emails.
When I ran this code on my work email account, it didn't give me a thing. I found that it had trouble reading "Undeliverables" emails, and every time after I ran it, one of the undeliverables emails turned into Traditional Chinese characters which cannot be read.
格浴㹬格慥㹤洼瑥瑨灴攭畱癩∽潃瑮湥祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰∶猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨慦汩摥琠桴獥敲楣楰湥獴漠牧畯獰㰺是湯㹴⼼㹢⼼㹰昼湯⁴潣潬
I feel this code works on only forwarded undeliverable email, in my test email inbox.
It never read from the original undeliverable emails and turned those emails to Chinese characters one by one.
I googled it, it seems there are bugs in Outlook for the failed delivery emails. How to fix this?
After frustrated several days, I finally came up a much simpler solution, which doesn't need to worry about any restriction of NDR in Outlook or even never use VBA at all...
What I did is:
Select all the non-delivery emails in Outlook
Save as a ".txt" file
Open Excel, open the txt file and select "Delimited" and select "Tab" as delimiter in the "Text Import Wizard"
filter out the column A with "To:", then will get all the email address on column B
Can't believe this is much simpler than VBA...
Thank you guys for your help! Just can't really deal with the "Outlook NDR turning to unreadable characters" bug with so many restrictions on a work station, think this might be helpful!
For getting addresses... I can pull the address from the action.reply which creates an outlook message with a body and sender:
Sub Addressess_GET_for_all_selected()
Dim objSel As Selection
Dim i As Integer
Dim objMail As MailItem
Dim objRept As ReportItem
Dim oa As Recipient
Dim strStr As String
Dim objAct As Action
Set objSel = Outlook.ActiveExplorer.Selection
Dim colAddrs As New Collection
On Error GoTo 0
frmProgress.SetMax (objSel.Count)
'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR
On Error GoTo SkipObj: ''for unhandled types
For i = 1 To objSel.Count
Set objMail = Nothing
If objSel(i).Class = olReport Then ''report email addresses 2020-02-12
Set objRept = Nothing
Set objRept = objSel(i)
For Each objAct In objRept.Actions
If objAct.Name = "Reply" Then
Set objMail = objAct.Execute
Exit For
End If
Next objAct
End If
''fire on objmail or if is omail
If objSel(i).Class = olMail Then
Set objMail = objSel(i)
End If
If Not objMail Is Nothing Then
DoEvents
For Each oa In objMail.Recipients
colAddrs.Add GetSMTPAddress(oa.Address)
Next oa
On Error Resume Next '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
colAddrs.Add GetSMTPAddress(objMail.sender.Address)
On Error GoTo 0 '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
objMail.Delete
End If
SkipObj:
frmProgress.SetCurrent (i)
Next i
SortDedupCollection_PUSH colAddrs
frmProgress.Hide
End Sub
And GET SMTP:
Private Function GetSMTPAddress(ByVal strAddress As String) As String
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Recipient ' Object
Dim strRet As String
Dim fldr As Object
'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
On Error Resume Next
If InStr(1, strAddress, "#", vbTextCompare) <> 0 Then
GetSMTPAddress = strAddress
Exit Function
End If
Set olApp = Application
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
If fldr Is Nothing Then
olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Add "Random"
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
End If
On Error GoTo 0
If CInt(Left(olApp.VERSION, 2)) >= 12 Then
Set oRec = olApp.Session.CreateRecipient(strAddress)
If oRec.Resolve Then
On Error Resume Next
strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
If strRet = "" Then
strRet = Split(oRec.AddressEntry.Name, "(")(2) ''at least provide name.
strRet = Left(strRet, InStr(1, strRet, ")") - 1)
End If
On Error GoTo 0
End If
End If
If Not strRet = "" Then GoTo ReturnValue
'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
'How it works
'============
'1) It will create a new contact item
'2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
'3) We will assign a random key to this contact item and save it in its Fullname to search it later
'4) Next we will save it to local contacts folder
'5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
'6) The display name will be something like this " ( email.address#server.com )"
'7) Now we need to parse the Display name and delete the contact from contacts folder
'8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
'9) We then need to delete it from Deleted Items folder as well, to clean all the traces
Set oCon = fldr.items.Add(2)
oCon.Email1Address = strAddress
strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = strKey
oCon.Save
strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
GetSMTPAddress = strRet
End Function
sI have been having exactly the same issue. All of the NDR messages I am dealing with are of the class "REPORT.IPM.Note.NDR" and the method I found for obtaining the original recipient was pieced together from a number of these sorts of posts and questions that I've been trawling through!
I am using the PropertyAccessor.GetProperty method against the ReportItem to obtain the PR_DISPLAY_TO property value from the header information of the ReportItem.
In VBA, I am using the MAPI namepace and looping through the olItems collection of a given folder containing the report messages. I'm running this from Access as my database front-end is built that way, but I would imagine you can probably run it from within Outlook VBA (but don't hold me to that).
Dim olApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.ReportItem
Dim OlItems As Outlook.Items
Set olApp = CreateObject("Outlook.Application")
Set OlMapi = olApp.GetNamespace("MAPI")
Set olFolder = OlMapi.Folders("SMTP-ADDRESS-FOR-YOUR-MAILBOX").Folders("Inbox").Folders("NAME-OF-SUBFOLDER_CONTAINING-NDR-REPORTS")
Set OlItems = olFolder.Items
If OlItem.Count > 0 Then
For Each olMail In OlItems
strEmail = olMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")
'DO WITH strEmail AS REQUIRED
DoEvents
Next
End If
The returned value from that MAPI property could be a semicolon delimited list where there are multiple recipients, so you could check for ';' in the returned string and then split into an array and iterate through to get each individual address, but in my case, there is only ever one recipient so I didn't need to over complicate it. It also may be a display name when the original recipient is a contact, so this may be a shortcoming for some, but again in my case, that's not a factor.
This is just a snippet of a bigger function so you will need to amend and integrate it to your needs, and obviously replace or amend the placeholders for the mailbox and subfolder values.
The intention is currently to also extract the NDR reason code so that I can automate removal of email addresses from our database where the reason is because the mailbox does not exist, so referring only to ReportItem object - This likely won't work for NDR emails which are not of that type, as I would image thoe MAPI properties are not available, however I have found in practice that all of the NDR messages come back like this as we are using Exchange Online.
I Did some tweaking to the original code in the first post,
and added a helper function to Extract Email From String, and seems to be working fine.
Sub List_Undeliverable_Email_To_Excel()
Dim myFolder As MAPIFolder
Dim Item As Outlook.MailItem 'MailItem
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Lines() As String
Dim i As Integer, x As Integer, P As Integer
Dim myItem As Variant
Dim subjectOfEmail As String
Dim bodyOfEmail As String
'Try access to excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
If xlApp Is Nothing Then
MsgBox "Excel is not accessable"
Exit Sub
End If
End If
On Error GoTo 0
'Add a new workbook
Set xlWB = xlApp.Workbooks.Add
xlApp.Application.Visible = True
Set xlSheet = xlWB.ActiveSheet
Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Real Estate").Folders("ag#joinreal.com")
For Each myItem In myFolder.Items
subjectOfEmail = myItem.Subject
bodyOfEmail = myItem.Body
'Search for Undeliverable email
If subjectOfEmail Like "*Undeliverable*" Or subjectOfEmail Like "*Undelivered*" Or subjectOfEmail Like "*Failure*" And subjectOfEmail Like "*Delivery*" Then 'bodyOfEmail Like "*Deliver*" And
x = x + 1
'Extract email address from email body
Lines = Split(bodyOfEmail, vbCrLf)
For i = 0 To UBound(Lines)
P = InStr(1, Lines(i), "#", vbTextCompare)
If P > 0 Then
EmailAdd = ExtractEmailFromString(Lines(i), True)
Debug.Print x & " " & EmailAdd
xlApp.Range("A" & x) = EmailAdd
Exit For
End If
Next
End If
Next
End Sub
Function ExtractEmailFromString(extractStr As String, Optional OnlyFirst As Boolean) As String
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Do While True
Index1 = VBA.InStr(Index, extractStr, "#")
getStr = ""
If Index1 > 0 Then
For P = Index1 - 1 To 1 Step -1
If Mid(extractStr, P, 1) Like CheckStr Then
getStr = Mid(extractStr, P, 1) & getStr
Else
Exit For
End If
Next
getStr = getStr & "#"
For P = Index1 + 1 To Len(extractStr)
If Mid(extractStr, P, 1) Like CheckStr Then
getStr = getStr & Mid(extractStr, P, 1)
Else
Exit For
End If
Next
Index = Index1 + 1
If OutStr = "" Then
OutStr = getStr
If OnlyFirst = True Then GoTo E
Else
OutStr = OutStr & Chr(10) & getStr
End If
Else
Exit Do
End If
Loop
E:
ExtractEmailFromString = OutStr
End Function
There is a problem with the ReportItem.Body property in the Outlook Object Model (present in Outlook 2013 and 2016) - you can see it in OutlookSpy (I am its author): select an NDR message, click Item button, select the Body property - it will be garbled. Worse than that, once the report item is touched with OOM, Outlook will display the same junk in the preview pane.
The report text is stored in various MAPI recipient properties (click IMessage button in OutlookSpy and go to the GetRecipientTable tab). The problem is the ReportItem object does not expose the Recipients collection. The workaround is to either use Extended MAPI (C++ or Delphi) or Redemption (I am its author - any language) - its RDOReportItem.ReportText property does not have this problem:
set oItem = Application.ActiveExplorer.Selection(1)
set oSession = CreateObject("Redemption.RDOSession")
oSession.MAPIOBJECT = Application.Session.MAPIOBJECT
set rItem = oSession.GetRDOObjectFromOutlookObject(oItem)
MsgBox rItem.ReportText
You can also use RDOReportItem.Recipients collection to extract various NDR properties from the recipient table.