getting the outlook mail's latest status(replied or forwarded) - vba

I am working on an automation on mails in outlook VBA. I want to use PR_VERB_EXECUTION_TIME property to get the latest status of mail and check whether the mail has already been replied or forwarded and send mail if the mail is unattended. Any help in
Sub Test(Item AS MailItem)
//Item is my incoming mail
Dim Obj As Outlook.MailItem
Dim str As String
Dim propaccessor As Outlook.Propertyaccessor
Set propaccessor = Item.propertyAccessor
str = propaccessor.Getproperty("http://schemas.microsoft.com/mapi/proptag/0x10820040")
'Str value is setting to null due to which error is thrown
'but other properties are working fine
'i want to use this string and compare current time and then reply if it is equal to current time
End Sub
how to use the property is appreciated!.

for that you need to use PropertyAccessor.GetProperty Method
For Each mailItem In mailitems
If mailItem.Class <> olMail Then Exit For
Set propertyAccessor = mailItem.propertyAccessor
LastVerbExecuted = CheckBlankFields("PR_LAST_VERB_EXECUTED", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003"))
Select Case LastVerbExecuted
Case Last_Verb_Reply_All, Last_Verb_Reply_Sender, Last_Verb_Reply_Forward
Subject = mailItem.Subject
'This appears to be local time
RecievedTime = mailItem.ReceivedTime
'This appears to be GMT
strRepliedTime = CheckBlankFields("PR_LAST_VERB_EXECUTION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10820040"))
OriginalAuthor = mailItem.Sender
'Replier = ...
If strRepliedTime <> "" Then
'Convert string strRepliedTime to time format here...using a custom function
End If
LogData Subject, OriginalAuthor, Replier, RecievedTime, RepliedTime
Case Else
'in case you want to do something here
End Select
Next mailItem
Refer http://www.tek-tips.com/viewthread.cfm?qid=1739523
you can do this way
Const Last_Verb_Reply_All = 103
Const Last_Verb_Reply_Sender = 102
Const Last_Verb_Reply_Forward = 104
For Each mailItem In mailitems
If mailItem.Class <> olMail Then Exit For
Set propertyAccessor = mailItem.propertyAccessor
LastVerbExecuted = CheckBlankFields("PR_LAST_VERB_EXECUTED", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003"))
Select Case LastVerbExecuted
Case Last_Verb_Reply_All, Last_Verb_Reply_Sender, Last_Verb_Reply_Forward
'it means email already responded
exit sub
'i dont think there is need to check time
'strRepliedTime = CheckBlankFields("PR_LAST_VERB_EXECUTION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10820040"))
Case Else
'in case you want to do something here
End Select
Next mailItem

Related

Reading mail RTFbody fails with error 'not implemented'

I have code that reads mail to generate a task with the mail's content.
In a few cases this hits a problem, when reading the RTFbody from the mail, saying "not implemented".
Can I test against this? Like WHEN IS NULL ... which checks if a variable has appropriate content.
Sub CreateTempTaskFromMail()
Dim oMail As Outlook.MailItem
Set oMail = ActiveInspector.CurrentItem
Dim s, sNr As String
s = oMail.subject
Dim oTask As Outlook.TaskItem
Set oTask = CreateTaskWithTempFolder(s, False) ' Function creating and returing task
oTask.RTFBody = oMail.RTFBody
End sub
I tried to test several ways if RTFbody has a problem. All of these approaches throw an error.
If oMail.RTFBody Is Nothing Then Stop
If IsError(oMail.RTFBody) Then Stop
If IsMissing(oMail.RTFBody) Then Stop
If IsEmpty(oMail.RTFBody) Then Stop
If there is absolutely no real solution then
Option Explicit
Sub CreateTempTaskFromMail()
Dim oObj As Object
Dim oMail As mailItem
Dim oTask As TaskItem
Dim s As String
Set oObj = ActiveInspector.currentItem
If oObj.Class = olMail Then
Set oMail = oObj
s = oMail.subject
Set oTask = CreateTaskWithTempFolder(s, False) ' Function creating and returing task
' If you absolutely cannot determine the problem
' https://excelmacromastery.com/vba-error-handling#On_Error_Resume_Next
On Error Resume Next
oTask.RTFBody = oMail.RTFBody
If Err <> 0 Then
Debug.Print "Error was bypassed using a technique that is to be avoided."
Exit Sub
End If
' Consider mandatory AND as soon as possible
On Error GoTo 0
oTask.Display
Else
Debug.Print "not a mailitem"
End If
End Sub
Before accessing the RTFBody property in the code I'd suggest checking the item's type first to make sure such property exists for a specific item type:
If TypeOf item Is MailItem Then
' do whatever you need with RTFBody here
End If
Or
If TypeName(item) = "MailItem" Then
' do whatever you need with RTFBody here
End If
If you are using Office 2016 product, you should update office. It is early office 2016 build's bug.

Find out if an attachment is embedded or attached

I am coding a small VBA to show all attachments of an email in a list box.
The user can select attachments that should be removed from the email and stored on a target folder.
I am also adding a HTML file to the email that contains a list of all removed files (including a link to each file to the target folder).
I have a problem with images, because they can be
Attached as a normal file to the email
Embedded to the email body (like a company logo in the signature)
I want to show in my list box only those images, that are attached as files to the email.
Embedded mails should be ignored.
Sub SaveAttachment()
Dim myAttachments As Outlook.Attachments
Dim olMailItem As Outlook.MailItem
Dim lngAttachmentCount As Long
Dim Attachment_Filename As String
Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set olMailItem = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then Set olMailItem = .Item(1)
End With
If olMailItem Is Nothing Then Exit Sub
End Select
Set myAttachments = olMailItem.Attachments
If myAttachments.Count > 0 Then
For lngAttachmentCount = myAttachments.Count To 1 Step -1
'-------------------------------------------------------------------------
' Add the attachment to the list of attachments (form)
'-------------------------------------------------------------------------
Attachment_Filename = myAttachments(lngAttachmentCount).FileName
With UserForm1.lstAttachments
.AddItem (Attachment_Filename)
.List(lngAttachmentListPos, 1) = Attachment_Type_Text
.List(lngAttachmentListPos, 2) = FormatSize(myAttachments(lngAttachmentCount).Size) & " KB"
End With
Next lngAttachmentCount
End If
End Sub
I added only the relevant parts of the code, so I hope I have not forgotten anything.
At the moment I show all attachments (also embedded images).
How would I find out if an attachment is embedded?
I found a possible solution here:
Distinguish visible and invisible attachments with Outlook VBA
The source code provided is not working, it seems like the two URLs in line 2 and 3 no longer exist.
I'm not sure if this is a solution that is valid in all cases, but it works in my environment. That means "test it properly".
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Function IsEmbedded(Att As Attachment) As Boolean
Dim PropAccessor As PropertyAccessor
Set PropAccessor = Att.PropertyAccessor
IsEmbedded = (PropAccessor.GetProperty(PR_ATTACH_CONTENT_ID) <> "")
End Function
Call it with
If IsEmbedded(myAttachments(lngAttachmentCount)) Then
...
End If
The cryptic url-looking constant is not a url, but a property identifier. You can find a list of them here: https://interoperability.blob.core.windows.net/files/MS-OXPROPS/%5bMS-OXPROPS%5d.pdf
That property is set to the url of the attachment if embedded. If not embedded, then it is empty.
In the Outlook object model it's very important to marshal your objects correctly. Leaving a PropertyAccessor hanging about is not good, so I would suggest a minor modification to the accepted answer as follows:
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Function IsEmbedded(Att As Attachment) As Boolean
Dim PropAccessor As PropertyAccessor = Nothing
Try
PropAccessor = Att.PropertyAccessor
Return (PropAccessor.GetProperty(PR_ATTACH_CONTENT_ID) <> "")
Catch
Return False
Finally
If PropAccessor IsNot Nothing
Marshal.ReleaseCOMObject(PropAccessor)
End If
End Catch
End Function
With the help of the answer and comment from #DinahMoeHumm we went with this solution which seems to work:
Function outlook_att_IsEmbedded(Att As outlook.Attachment) As Boolean
Dim PropAccessor As outlook.PropertyAccessor
On Error GoTo outlook_att_IsEmbedded_error
outlook_att_IsEmbedded = False
Set PropAccessor = Att.PropertyAccessor
If PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") <> "" Or _
PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3713001E") <> "" Then
If PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") = 4 Then
outlook_att_IsEmbedded = True
End If
End If
outlook_att_IsEmbedded_exit:
Set PropAccessor = Nothing
Exit Function
outlook_att_IsEmbedded_error:
outlook_att_IsEmbedded = False
Resume outlook_att_IsEmbedded_exit
End Function
I don't know what the different probtags mean. Or what the 4 is. It seems like you could find a list of them here: https://interoperability.blob.core.windows.net/files/MS-OXPROPS/%5bMS-OXPROPS%5d.pdf (but I didn't)

Detect if the last selected email has been marked as read and prompt to save

My outlook VBA code aims at doing the following:
In the event of selection change (i.e. say the user clicks on a different email in the inbox)
If [the previously selected email was originally 'Unread' and just became 'Read'] Then
Prompt the user to save the previous email
Else
Do Nothing
End If
To do that I used the Explorer_SelectionChange event. The problem I'm facing is that outlook takes about 1 to 2 seconds before it marks the previous email as read! My code gets executed before these 2 seconds pass. Hence it always sees the previous email as unread! :(
I tried to introduce a pause to my Sub but it didn't work. Outlook waits until my code finishes including the pause before it in turn waits 1 to 2 seconds and then mark the previous email as read.
So in summary my question is: Is there an Event that identifies when the previously selected email is marked as Read?? (PS: I tried MailItem.Read Event but it is also instantaneous and applies to all 'read and unread' emails]
Here is the part of my code that specifically tries to achieve the above described functionality:
Public WithEvents myOlExp As Outlook.Explorer
Dim Flag As Integer
Dim oMail As Outlook.MailItem
Private Sub Application_Startup()
Dim objItem As Object
Set myOlExp = Application.ActiveExplorer
enviro = CStr(Environ("USERPROFILE"))
'Identify the status of the selected email at startup
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1 'Means Current selection is an unread email
Else
Flag = 0 'Means Current selection has been read before
End If
End Sub
Private Sub myOlExp_SelectionChange()
'If previous selected email was Unread
If Flag = 1 Then
If oMail.UnRead = False Then
MsgBox "previous email has just been read do you want to save?"
'^^This is where the problem happens: the previously selected email is always seen as read by the code
'because Outlook takes 1-2 seconds after the selection change event before it marks the email as read!!
Else
MsgBox "Previous email still marked as unread, do nothing"
'^^I am always getting this outcom when I change selection from an unread email to another email!
End If
'Now identify the status of the newly selected email
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1 'Means Current selection is an unread email
Else
Flag = 0 'Means Current selection has been read before
End If
Else
' Flag = 0 i.e previous email was already read
' Identify the status of the newly selected item.
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1
Else
Flag = 0
End If
End If
End Sub
I hope I managed to formulate my question clearly! Any help is most appreciated.
Many Thanks
Once you set Flag = 1, oMail.UnRead status does not matter.
If Flag = 1 Then
' Remove this test
'If oMail.UnRead = False Then
MsgBox "...

Outlook VBA Mailitem property SenderEmailAddress not returning address correctly

So I have a program in access that lets the user select an outlook folder to import to a table. Which then can be selected from a combobox and transferred across to a form for use.
However I am having a problem with one of the values I am getting returned. SenderEmailAddress is not actually giving me an email address, for example this is what I get saved in my table.
I have removed names for privacy.
/O=COMPANY/OU=MAIL12/CN=RECIPIENTS/CN=FIRSTNAME.LASTNAME
Now of course, if I want to pass this value back over to outlook to reply to the email, I cannot use this.
Can anybody help me please?
Public Sub LoadEmails()
On Error Resume Next
'Outlook wasn't running, start it from code
If Started = False Then
Set olApp = New Outlook.Application '("Outlook.Application")
Started = True
End If
Set myNamespace = olApp.GetNamespace("MAPI")
Set objFolder = myNamespace.PickFolder
' if outlook is closed, it will display this error
If Err <> 0 Then
MsgBox "Outlook was closed. Please log out and log back in."
Started = False
Exit Sub
End If
'Exit if no folder picked.
If (objFolder Is Nothing) Then
MsgBox "No Folder Selected"
Started = False
Exit Sub
End If
Dim adoRS As Recordset
Dim intCounter As Integer
Set adoRS = CurrentDb.OpenRecordset("TBL_UserInbox") 'Open table Inbox
'Cycle through selected folder.
For intCounter = objFolder.Items.Count To 1 Step -1
With objFolder.Items(intCounter)
'Copy property value to corresponding fields
If .Class = olMail Then
adoRS.AddNew
adoRS("Subject") = .Subject
adoRS("TimeReceived") = .ReceivedTime
adoRS("Body") = .Body
adoRS("FromName") = .SenderEmailAddress '<<< Issue
adoRS("ToName") = .To
adoRS.Update
End If
End With
Next
MsgBox "Completed"
Started = False
End Sub
That is a perfectly valid email address of type EX (as opposed to SMTP). Check the MailItem.SenderEmailType property. If it is "SMTP", use the SenderEmailAddress property. If it is "EX", use MailItem.Sender.GetExchangeUser.PrimarySmtpAddress. Be prepared to handle nulls/exceptions.

Forward a highlighted email to a specific recipient

How do I forward a highlighted email to a specific recipient?
Is it possible to link that to a CTRL-ALT- shortcut?
I'm on Windows 7, Outlook 2010
Ctrl+Alt does not appear to be a feature of Outlook 2003 so I cannot comment on it. I can run the following macro by adding the macro to a toolbar using Tools, Customise.
This macro will forward all selected items. If you want to ensure only one item is selected, test SelectedItems.Count. If the current folder is empty, nothing happens because SelectedItems.Count = 0
Sub ForwardSelectedItems()
Dim Inx As Integer
Dim NewItem As MailItem
Dim SelectedItems As Outlook.Selection
Set SelectedItems = ActiveExplorer.Selection
For Inx = 1 To SelectedItems.Count
Set NewItem = SelectedItems.Item(Inx).Forward
With NewItem
' ########## Remove following block if attachments are to be sent.
' Delete any attachments.
With .Attachments
While .Count > 0
.Remove 1
Wend
End With
' ########## Remove above block if attachments are to be sent.
With .Recipients
' Add new recipient. Note Forward deletes existing recipients.
.Add "my.friend#isp.com"
End With
' Choices ######
'.Display ' Show to user and let them send if they wish
.Send ' Send automatically without showing to user
' End of choices ######
End With
Next
End Sub
Forward a highlighted email to a specific recipient
Return the currently highlighted email:
GetCurrentItem will return the currently selected or opened email to the calling procedure.
Function GetCurrentItem() As Object
' returns reference to current item, either the one
' selected (Explorer), or the one currently open (Inspector)
Select Case True
Case IsExplorer(Application.ActiveWindow)
Set GetCurrentItem = ActiveExplorer.Selection.item(1)
Case IsInspector(Application.ActiveWindow)
Set GetCurrentItem = ActiveInspector.CurrentItem
End Select
End Function
Function IsExplorer(itm As Object) As Boolean
IsExplorer = (TypeName(itm) = "Explorer")
End Function
Function IsInspector(itm As Object) As Boolean
IsInspector = (TypeName(itm) = "Inspector")
End Function
Forward the selected email:
This uses the above functions to forward and display an email. The rest is up to you.
Sub FwdMail()
Dim obj As Object
Dim msg As Outlook.MailItem
Set obj = GetCurrentItem
If TypeName(obj) = "MailItem" Then
Set msg = obj
With msg
.Forward
.Display
End With
End If
End Sub