Get Current Body via Active Explorer in Currently Sending Email - vba

Been trying various approaches from either experimenting or googling but cant seem to figure this one out.
In this code, when the email is being sent from the explorer via a reply, it only grabs the body from below what is "being sent now" instead of a lof it. I assume there is an object I haven't been able to find intuitively that holds this but I cant seem to figure out.
Anyone know what I might be over looking?
Code used
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
Dim msg As MailItem
Set msg = GetCurrentItem()
prompt = msg.Body
MsgBox prompt
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function

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.

Outlook VBA fails to save changes to MailItem on older items only

I have a macro in Outlook VBA that is designed to set the category of the selected email and send a reply email to the sender when a user clicks a button on the "Ribbon".
The below code will properly set the category on any newer emails, but throws "Run-time error '440': Cannot save this item." when run on emails that have been sitting around for a while. I don't know what causes this, as it runs fine for a while and then no longer works.
I tried restarting Outlook, logging in and logging out, and restarting the computer, and none of these seem to trigger the change in behavior, so I believe it is somehow related to the duration that the email has been sitting. This is rather confusing, as I don't see why length of time sitting in the folder should affect the ability to save, but not the ability to access the properties of the MailItem.
A simplified version of the code (without the email-sending part, which works fine) is as follows:
Public Sub UpdateCategory
Dim objItem as Object
Set objItem = GetCurrentItem()
'Verify that selected item is an email and an engineering request
If TypeName(objItem) = "MailItem" And InStr(LCase(objItem.Subject), "engineering request") > 0 Then
objItem.Categories = "Test"
objItem.Save
End If
Set objItem = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Any thoughts or suggestions would be greatly appreciated!!
Is this is an Exchange mailbox, it is possible that Exchange modified the item on the server side, that change was downloaded to the OST file, but since Outlook Object Model is not aware of the change, when you try to save the (stale) item, you get a conflict error.

Writeable active inline response in outlook

I have the following code from some blog that inserts HTML from the clipboard into an outlook email.
Sub PrependClipboardHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Set email = Application.ActiveInspector.CurrentItem
Set cBoard = New DataObject
cBoard.GetFromClipboard
email.HTMLBody = cBoard.GetText + email.HTMLBody
Set cBoard = Nothing
Set email = Nothing
End Sub
It works great except that the email has be in its own window (i.e. popped-out) otherwise it will fail.
I was looking around on the documentation and found Application.ActiveExplorer.ActiveInlineResponse here.
However the documentations says that it is read-only, and indeed it does not work. Is there way to get a writable version of the inline response?
It works great except that the email has be in its own window (i.e. popped-out) otherwise it will fail.
That is because you have the following statement in the code:
Set email = Application.ActiveInspector.CurrentItem
However the documentations says that it is read-only, and indeed it does not work.
Try to use the following code instead:
Set email = Application.ActiveExplorer.ActiveInlineResponse
The ActiveInlineResponse property is read-only, but not the object's properties you are going to use. That means you can't set another mail item to the inline response, but will be able to set up properties of the retrieved item.
Maybe you're trying to work with ActiveExplorer + Selection.Item Method (Outlook)
Example
Option Explicit
Public Sub Example()
Dim email As Outlook.MailItem
Set email = Application.ActiveExplorer.Selection.Item(1)
Debug.Print email.Subject ' print on immediate window
End Sub
Or Work with both opened and selected items
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
You cannot concatenate two HTML strings and expect a valid HTML back. The two must be merged.
That being said, use Word Object Model to paste from the clipboard:
Application.ActiveEXplorer.ActiveInlineResponseWordEditor.Application.Selection.Paste()

Whenever a mail is sent from Outlook 2010 that mail should move to dedicated folder in Outlook, using VBA/Macros

I have already wrote a code where the when ever a email comes from a definite email ID to outlook my ID it gets sent to anothee email address automatically by using one rule.
Now I have to add one feature. This mail which is sent is also saved in a dedicated folder other than sent items. All this in one script.
This my current script where only the mail goes automatically. Now I need help to add the dedicated folder feature.
Sub Project_1()
Dim objMail As Outlook.MailItem
Set objItem = GetCurrentItem()
Set objMail = objItem.Forward
objMail.To = "inbox#email.com"
objMail.Display
objMail.Send
Set objItem = Nothing
Set objMail = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function
I am very new to VBA.
As #destination-data stated above, the whole task will be much easier through outlooks rules.
This article is a step-by-step guide on how to set rules for moving certain mails based on conditions. Additionally you can easily add a "forward" rule, since all your desired functionality is already implemented into outlook and one should avoid rewriting existing tools.
According to your description, this should accomplish the exact same thing as intended by your code.

How to save digital signature of received mail

I am trying to save the digital signature of the currently opened mail item.
Now I realize that Outlook prevents access to encrypt/sign a new email programmatically. Here I am focused on messages which have been received.
So far, I am just able to use the MessageClass property to detect a signed email.
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select
Set objApp = Nothing
End Function
Sub DoExport()
Set CurrentItem = GetCurrentItem()
If CurrentItem.MessageClass = "IPM.Note.SMIME.MultipartSigned" Then
MsgBox CurrentItem.MessageClass
End If
End Sub
Messageclass always seems to be "IPM.Note" even on encrypted and signed mail.
I use this code to read who signed the mail.
Set PropertyAccessor = mailitem.PropertyAccessor
If PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00020328-0000-0000-C000-000000000046}/9104001f") <> "" Then
END
End If