I have some VBA that checks the subject of every message as soon as it hits my inbox, and submits certain emails' contents over http to a server for processing.
This works great for messages with no attachments, but fails if there is an attachment on the email. I am using a http GET to submit the text.
What is the effect of the presence of an attachment on the body property of the message, and how can I ignore the attachment and submit only the email body text?
The VBA (trimmed for clarity but complete and functional):
Declarations:
Option Explicit
Private WithEvents olInboxItems As Items
On startup:
Private Sub Application_Startup()
Set olInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
On item added to inbox:
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim olMailItem As MailItem
Dim strAttachmentName As String
Dim submitResult As String
If TypeOf Item Is MailItem Then
Set olMailItem = Item
If ((InStr(olMailItem.subject, "test subject") > 0)
Dim subject As String
subject = olMailItem.subject
Dim contents As Variant
contents = olMailItem.body
Dim submitURL As String
submitURL = "http:// ... " & subject & "..." & contents & "..."
XMLHttpSynchronous submitURL
End If
End If
Set Item = Nothing
Set olMailItem = Nothing
End Sub
Http submit:
Sub XMLHttpSynchronous(ByVal URL As String)
Dim XMLHttpRequest As XMLHTTP
Set XMLHttpRequest = New MSXML2.XMLHTTP
XMLHttpRequest.Open "GET", URL, False
XMLHttpRequest.Send
End Sub
edit: I am now stripping attachments with the below code (tested and working) but the url still isn't submitting correctly.
Set myattachments = olMailItem.Attachments
While myattachments.Count > 0
myattachments.Remove 1
Wend
edit 2: I set contents=subject and the url submitted correctly, still no luck with the email's body, even after the message has been stripped of attachments
In order to get this working I stripped the attachments with the code in my first edit, than split the string of the body's text around the first and last character. I'm not sure why this works
Related
I want to encrypt whenever an attachment with PDF extension is added to mail with Outlook vba.
Is there a way to write such a macro?
Thanky you?
You can handle the MailItem.AttachmentAdd event which is fired when an attachment has been added to an Outlook item. So, you could check the attached file - the Attachment that was added to the item is passed as a parameter and encrypt it if required. For example:
Public WithEvents newItem As Outlook.MailItem
Private Sub newItem_AttachmentAdd(ByVal newAttachment As Attachment)
If newAttachment.Type = olByValue Then
newItem.Save
If newItem.Size > 500000 Then
MsgBox "Warning: Item size is now " & newItem.Size & " bytes."
End If
End If
End Sub
Public Sub TestAttachAdd()
Dim atts As Outlook.Attachments
Dim newAttachment As Outlook.Attachment
Set newItem = Application.CreateItem(olMailItem)
newItem.Subject = "Test attachment"
Set atts = newItem.Attachments
Set newAttachment = atts.Add("C:\Test.txt", olByValue)
End Sub
Note, you can find the cached file on disk. You can find the actual path in the windows registry:
I have been tasked to create an automated report system where an report from Google Data Studios are uploaded to specific projects (On a site called Basecamp). The reports always include both a report within the body of the e-mail and an attached PDF file. The are sent to a Gmail account (data studios refuse to schedule towards a non-Google account). The filters within Gmail doesnt really work well with the Basecamp system so I use filters to re-route them towards a Outlook account. There I use rules to send each e-mail towards the correct client within Basecamp.
Here comes the problem, Basecamp shows both the body of the e-mail AND the attached PDF version which makes us show duplicates.
Is there a way to create a macro that first deletes all attachments (or body of an e-mail) and THEN forward the e-mail.
It cant be done manually it have to be a rule that does it automaticaly. Keep in mind that I am not a coder and have never done anything like this so please keep it simple for my dumb brain!
Thank you in advance!
Marcus
PS: I found a code that seems to be what I am after.
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
I am trying to get that code to work, and changes the subject to a specific word and then route it to a final e-mail account that then filters out to correct clients. However the code doesnt seem to work, it DOES forward the e-mail but the attachment is still there. The code was found at https://www.extendoffice.com/documents/outlook/5359-outlook-forward-attachment-only.html#a1
It seems you need to modify the code slightly:
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
Dim myattachments as Outlook.Attachments
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
Set myattachments = xForwardMail.Attachments
While myattachments.Count > 0
myattachments.Remove 1
Wend
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
The Remove method of the Attachments class removes an object from the collection.
I'd like to remove the following phrase from the beginning of every email from sources other than a specific domain:
"This is an EXTERNAL email. Do not click links or open attachments unless you validate the sender and know the content is safe."
I am trying to delete this phrase from each email.
I grabbed some code online from another person trying to do something similar.
Sub Del()
Dim Ins As Outlook.Inspector
Dim Document As Word.Document
Dim Word As Word.Application
Dim Selection As Word.Selection
Set Ins = Application.ActiveInspector
Set Document = Ins.WordEditor
Set Word = Document.Application
Set Selection = Word.Selection
Dim search As String
search = "This is an EXTERNAL email. Do not click links or open attachments unless you validate the sender and know the content is safe."
Dim para As Paragraph
For Each para In Document.Paragraphs
Dim txt As String
txt = para.Range.Text
If InStr(txt, search) Then
para.Range.Delete
End If
Next
End Sub
I get
Run-time error '91'
on line 9 Set Document.
that works a lot easier within Outlook:
sub delete_part_of_text()
Dim search As String
search = "This is an EXTERNAL email. Do not click links or open attachments unless you validate the sender and know the content is safe."
If Not TypeOf Item Is mailitem Then Exit Sub
Item.HTMLBody = Replace(Item.HTMLBody, search, "")
end sub
of course you have to adapt this - should this run automatically on each incoming mail oder are you going to call this when needed for one/some mails? That changes the call of the procedure, but the princip abobe works.
Max
I've read this: VBA Outlook 2010 received mail .Body is empty but it is old and the other question referenced in the answer(s) is not found when I click on it.
Here's my basic code.
Sub AutoReplyTrap(objInMail As MailItem)
Dim objOutMail As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim strID As String
Dim sSubject As String
Dim vItem As Variant
Dim vFirstName As Variant
Dim i As Long
Dim j As Integer
Dim strSignature As String
Dim strSigString As String
Dim strFirstName As String
Dim strFirstLetter As String
Dim strEMailAddress As String
Dim blnFirstName As Boolean
Dim blnEMail As Boolean
' change the bodyformat to plain text
objInMail.BodyFormat = Outlook.OlBodyFormat.olFormatPlain
objInMail.Display
blnFirstName = False
blnEMail = False
j = 0
' believe there is a timing issue that Body may not be fully loaded.
' so I'm going to pause and loop through 20 times to see if it gets loaded.
WaitForBody:
sText = objInMail.Body
If sText = "" Then
If j < 20 Then
j = j + 1
Sleep 1000
GoTo WaitForBody
End If
End If
If sText = "" Then
MsgBox ("No body in email!")
Exit Sub
End If
End Sub
I thought it was a timing issue, so I built the loop to test if I have the body, and if not, wait a second and try again up to 20 times.
I have objInMail.Display it works, but if I remove that line it will loop through the 20 attempts.
I could live with the display if I could then "un-display" it, but I wonder if the .close will close everything with the email and I'll lose the body again.
I'd prefer it to work without the objInMail.Display.
Ignoring the cause, this may provide a workaround without .Display.
Option Explicit
Private Sub test_GetInspector()
Dim currSel As Object
Set currSel = ActiveExplorer.Selection(1)
If currSel.Class = olMail Then
AutoReplyTrap_GetInspector currSel
End If
End Sub
Sub AutoReplyTrap_GetInspector(objInMail As mailItem)
' change the bodyformat to plain text
objInMail.BodyFormat = OlBodyFormat.olFormatPlain
' objInMail.GetInspector ' Previously "valid".
' My setup finally caught up and provided the clue.
' Directly replacing .Display with .GetInspector
' Compile error:
' Invalid use of property
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim objInspector As Inspector
Set objInspector = objInMail.GetInspector
' You should find this is necessary
'objInMail.Save
End Sub
Working with Outlook 2010 right now and have an update. The issue is caused by a bug in Outlook 2010/2013 that only gives a blank message body in VBA when:
(1) using IMAP protocol; and,
(2) automatically processing incoming emails.
This holds true even if you just set a Rule from the front end, such as automatically printing specific incoming emails (my task). This prints the email header, not the body.
A workaround that worked for me was to use POP3 protocol instead of IMAP with the same email server.
Below is the code that I am running in ThisOutlookSession. The code is meant to check all incoming emails and if the email is from a certain email address and contains a specific string in the subject then a new email is created from a template and the triggering email is attached and the email is then sent out to a different email address. This portion all works fine.
Also to note I am using windows 10 and office 2016.
The problem that I am having is the email is converted to plain text unless it is displayed first. The template that I have created is saved as a HTML formatted message. I have tried adding lines such as
NewMsg.BodyFormat = olFormatHTML
NewMsg.save
But this doesn't seem to work as the email that is sent was still in the plain text format. If I add the following to that the message it basically works.
NewMsg.BodyFormat = olFormatRichText
NewMsg.save
NewMsg.BodyFormat = olFormatHTML
NewMsg.save
However the above block of code removes a lot of the formatting that was saved in my template such as different fonts/ font sizes.
Am I missing something about working with templates in VBA?
Also The problem that I am having with displaying the message first is two things. The obvious one is the flash that this causes because the message is briefly displayed. The second is my default signature is also added to the displayed message but I wanted to use a custom signature that I built into my template.
Here is my full code with sensitive information removed.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim NewMsg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress <> "example#example.com" Then GoTo Skip
If InStr(1, Msg.Subject, "Specific String") > 0 Then 'checks if subject contains the proper string
Set NewMsg = Application.CreateItemFromTemplate("Template Path")
Msg.Subject = Replace(Msg.Subject, "Old Subject", "New subject")
Msg.Save
NewMsg.HTMLBody = NewMsg.HTMLBody
NewMsg.Attachments.Add Msg
NewMsg.Recipients.Add("Example#Example.com")
NewMsg.Subject = Msg.Subject
NewMsg.Save
NewMsg.Send
End If
End If
Skip:
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
End Sub
Reset the HTMLBody property - that will force HTML format:
Msg.HTMLBody = Msg.HTMLBody