MailItem.Send in VBA not functioning since Office 365 upgrade - excel

We send out a lot of spreadsheets around the organisation, in order to automate this as much as possible we wrote some code to send this automatically and allow us to still put body text in.
This particular Script picks information up from our Finance System (SAP) dumps it into Excel and emails it to the user, it loops through a number times downloading and emailing different data each time.
This works fine on our old windows 7 (Office 2010) machines but some of us have been given new Windows 10 (Office 365) machines to pilot.
The code runs without any error messages but when it gets to .Send it jumps straight to End Sub and does not send the email.
I have tried EmailItem.Display and you can see the email being populated and then just stays visible on the desktop as it loops through the rest of the emails.
Any ideas on how to get round this? I could use the application.send function but I like to have the ability to add custom text into the email body.
Thanks :)
Sub EmailData()
Dim OL As Object
Dim EmailItem As Object
Dim y As Long
Dim TempChar As String
Dim Bodytext As String
Dim Flds As Variant
Dim EmailText As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Email Download to nursery
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.Createitem(OLMailItem)
'Check File Name is correct
Filename = Range("A1") & ".xls"
For y = 1 To Len(Filename)
TempChar = Mid(Filename, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
ActiveSheet.Cells.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
With ActiveWindow
.DisplayGridlines = False
.DisplayZeros = False
End With
Range("A1:S38").Select
Selection.Locked = True
Selection.FormulaHidden = False
Set EmailText = ActiveSheet.Range("AB1:AB5").SpecialCells(xlCellTypeVisible)
ActiveSheet.Protect ("keepsafe")
ActiveWorkbook.SaveAs Networkpath & "\" & SaveName, , "", , True
ActiveWorkbook.ChangeFileAccess xlReadOnly
EmailItem.display
'On Error Resume Next
With EmailItem
.To = "Daston#blahblah.uk"
'.To = Range("AA1")
.CC = ""
.BCC = ""
.Subject = Filename
.HTMLBody = RangetoHTML(EmailText)
.Attachments.Add ActiveWorkbook.FullName
.send
End With
Application.Wait (Now + TimeValue("0:00:02"))
Kill Networkpath & "\" & SaveName
ActiveWorkbook.Close False
Set OL = Nothing
Set EmailItem = Nothing
End Sub

This describes how, in certain situations, you may "make the object model fully functional".
NameSpace.Logon Method (Outlook)
"first, instantiate the Outlook Application object, then reference a default folder such as the Inbox. This has the side effect of initializing MAPI to use the default profile and to make the object model fully functional."
Sub InitializeMAPI ()
' Start Outlook.
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
' Get a session object.
Dim olNs As Outlook.NameSpace
Set olNs = olApp.GetNamespace("MAPI")
' Create an instance of the Inbox folder.
' If Outlook is not already running, this has the side
' effect of initializing MAPI.
Dim mailFolder As Outlook.Folder
Set mailFolder = olNs.GetDefaultFolder(olFolderInbox)
' Continue to use the object model to automate Outlook.
End Sub

For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses.
HKCU\Software\Policies\Microsoft\office\16.0\outlook\security\
promptoomaddressbookaccess
promptoomaddressinformationaccess
https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
The most probable cause is Outlook Security.
You can find the security configurations in HKCU\Software\Policies\Microsoft\office\16.0\outlook\security
(change 16.0 to your office version)
Change promptoomsend to 2 (or ask your system administrator), restart Outlook and try again.
More info https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

Related

Bulk send Emails based on VBA Filtered Table from Excel

I frequently have to send out emails to various contractors to check in on the statuses of the projects I have bid with them. Currently I have to enter the name of each Rep in reference cell and then execute the macro but I deal with dozens of reps. I would like to be able to send an bulk email blast out to all the reps whose projects are still "Open" with one macro instead of having to change the reps name each time. Also, I tried to use the automatic .send function but cannot get it to work and I would hope to not have to keep using the .display for this situation for obvious reasons.
Sub EmailGCs_1()
'Declare Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
'Declare Word Variables
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim oWrdTble As Word.Table
'Declare Excel Variables
Dim ExcTbl As ListObject
On Error Resume Next
'Get The Active instance of Outlook, if there is one.
Set oLookApp = GetObject(, "Outlook. Application")
'If ther is no active instance create one
If Err.Number = 429 Then
'Create a new instance
Set oLookApp = New Outlook.Application
End If
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
'Create a refernce to the table
Set Exltbl = ActiveSheet.ListOjects(1)
With oLookItm
'Basic Info
.To = Range("D2").Value
.Subject = "Various Project Statuses"
'Display Email
.Display
'Get The Inspector
Set oLookIns = .GetInspector
'Get the Word Editor
Set oWrdDoc = oLookIns.WordEditor
'Filter Table to Distro
ActiveSheet.Range("Table1").AutoFilter field:=6, Criteria1:=Cells(1, 6).Value
'Hide Columns
Range("G:R").EntireColumn.Hidden = True
'Copy Items
Worksheets(1).ListObjects("Table1").Range.Copy
oWrdDoc.Range(1, 2).Paste
'Greeting Text
MsgText = Split(Range("F1").Value, " ")(0) & "," & vbNewLine & "Can you please let me know the statuses of the projects below." & vbNewLine
oWrdDoc.Range.InsertBefore Text:=MsgText
'Clearing out filter and selection
ActiveSheet.ListObjects(1).AutoFilter.ShowAllData
Application.CutCopyMode = False
Range("G:R").EntireColumn.Hidden = False
End With
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
End Sub
The Send method is not safe and the Outlook object model may trigger security prompts or give errors when Outlook is automated from an external application. Possible workarounds are listed below:
Create a COM add-in which deals with a safe Application instance which doesn't trigger security prompts.
Use a low-level code on which Outlook is built on and which doesn't have security riggers onboard. Or may also consider any other third-party wrappers around that API, for example, Redemption.
Use a third-party components for suppressing Outlook security warnings. See Security Manager for Microsoft Outlook for more information.
Use group policy objects for setting up machines.
Install any AV software with latest updates.
Here is one way to loop through a list.
Source: Sending Email to a List of Recipients Using Excel and Outlook
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub EmailGCs_2()
' Early binding requires reference to Microsoft Outlook XX.X Object Library
' Declare Outlook variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim iCounter As Long
'Application.ScreenUpdating = False
'There can only be one instance of Outlook
' GetObject is not needed.
' The problematic On Error Resume Next can be dropped
Set oLookApp = New Outlook.Application
'Subsequent errors would have been bypassed
' due to the missing On Error GoTo 0
'If there are any errors you can fix them now.
'Assumes a list of email addresses in column D starting at cell D2
' https://learn.microsoft.com/en-us/office/vba/excel/concepts/working-with-other-applications/sending-email-to-a-list-of-recipients-using-excel-and-outlook
'Debug.Print WorksheetFunction.CountA(Columns(4)) + 1
For iCounter = 2 To WorksheetFunction.CountA(Columns(4)) + 1
'Debug.Print iCounter
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
With oLookItm
'Basic Info
.To = Cells(iCounter, 4).Value
.Subject = "Various Project Statuses"
'Display Email
.Display
End With
Set oLookItm = Nothing
Next
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub

Range to IMG is empty when sent

I use this https://stackoverflow.com/a/48897439/14866652 to a range as an image into an Outlook email.
I don't want the screen to display so I changed the .Display to .Send. The mail is sent empty:
Public Sub enviarmail()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set Sht = ActiveWorkbook.Sheets("Cierre de ventas")
Set rng = Sht.Range("B23:N35")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.BodyFormat = 2
.To = Range("D13").value
.CC = Range("D14").value
.Subject = Range("D15").value
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
wdDoc.Range.InsertAfter vbLf & vbLf & "Firmado: " & Range("K13").value
With wdDoc
.InlineShapes(1).Height = 260
End With
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
Update: after several tests, #urdearboy's Potential Workaround #2 works, no need to use a buffer too, I've tried before without the buffer and I did not got it to work.
Using .Display and .Send at the same time works.
Potential Workaround #1
I've ran into a similar issue that only occurs when adding objects to body outside of text or a direct file upload. The only way I have been able to solve is to add a time buffer between the file being added and the email being sent.
I know the answer here is not satisfying, but worth a try:
Application.Wait Now + #12:00:01 AM#
.Send
Here is the question I posted with issue. I bountied this and still got no solution so settled with the time delay eventually
Potential Workaround #2
You can also try to first display and then send email. Same as above, this seems like a workaround to the actual problem but may be worth a try. If you are just sending one email then this could be a acceptable route to go. If many, then it may slow down the process and become less ideal.
With Email
'Email Attributes
.Display
.Send
End With

Find Outlook Email with keywords in Subject & attachment using Excel VBA

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

Extract text string from undeliverable email body to Excel

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.

Create Outlook appointment in specific Calendar from Excel

I am trying to create three Outlook appointments in a specific (shared) calendar.
The events will be all-day events. I want the dates for the current row to be added to the calendar. All three dates will be in the same row on the spreadsheet.
The code creates the appointment but the for loop is not working. The only event that is created is the last date.
Sub Makeapt()
Set myOutlook = CreateObject("Outlook.Application")
Set myApt = myOutlook.createitem(1)
Dim i As Integer
For i = 3 To 5
myApt.Subject = Cells(ActiveCell.Row, 1).Value
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
I solved the problem. Appt still goes to the default calendar, but that is actually preferable.
Sub Makeapt()
Dim warning
warning = MsgBox("You are about to create Outlook appointments for subject #" & Cells(ActiveCell.Row, 3) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub
Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 3)
Dim i As Integer
For i = 7 To 9
Set myApt = myOutlook.createitem(1)
myApt.Subject = "Subject #" & ID
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
Dmitry nailed it for how to create an appointment/meeting in a shared calendar from Excel. His post was a big help to me as it seems there are not any very good answers to how to create an appointment on a shared calendar. I looked all over numerous forums to get answers and came up with very little. Based on his answer, I was able to get it working. Below is an example script I put together. This is a somewhat stripped-down version of what I am using for my needs, but I did test this example and it works. Just make sure the Outlook library is selected in the Excel VBA editor's Tools->References menu item.
Sub SendInvitationAsUser()
Rcpts = "user#test.com; user2#test.com, etc#test.com" ' These can be in other formats that Outlook understands like display name.
Subject = "Meeting sent from shared calendar"
' Creates Outlook instance
Set OutApp = CreateObject("Outlook.Application")
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim objfolder As Outlook.Folder
Set myNamespace = OutApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Smith, John Q") 'The invite will come from this user's mailbox
myRecipient.Resolve
If myRecipient.Resolved Then
Set objfolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 'Sets folder where appt will be created
Else
ok = MsgBox("Unable to resolve the name of the sender.", vbCritical, "Error")
Exit Sub
End If
Set OutlookAppt = objfolder.Items.Add(olAppointmentItem) 'Creates appointment in shared calendar
' Edit Outlook appointment, convert to meeting invitation by adding recipients.
With OutlookAppt
.MeetingStatus = olMeeting
.Subject = Subject
.Start = #1/1/2018 8:00:00 AM#
.End = #1/1/2018 9:00:00 AM#
.Location = "Conference Room 1"
.RequiredAttendees = Rcpts
End With
'Use Word to do fancy formatting of body text. Example below is basic but a lot of formatting via VBA is possible.
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
Set DocSelection = WordApp.Selection
WordApp.Visible = True
WordDoc.Activate ' You want to see the window, right?
DocSelection.Font.Name = "Arial" ' Everything is Arial.
DocSelection.Font.Size = "10" ' Everything is size 10.
DocSelection.ParagraphFormat.SpaceAfter = "0" ' No line spacing.
DocSelection.ParagraphFormat.SpaceBefore = "0" ' No line spacing.
DocSelection.TypeText ("Please plan to attend my meeting.")
WordDoc.Content.Copy
OutlookAppt.Display
Set TargetApptDoc = OutlookAppt.GetInspector.WordEditor
TargetApptDoc.Range(0, 0).Paste
WordDoc.Close savechanges:=False
WordApp.Quit
End Sub
If you want a shared calendar, create a recipient object using Application.CreateRecipient, open the shared calendar using Application.Session.GetSharedDefaultFolder, create an appointment using MAPIFolder.Items.Add.

Resources