Solved: Append copy of XML attachment to Message Body

[adenter]

I have been failing to find a way to add functionality to Outlook that would allow me to apply the contents of a XML attachment as message text. After this is done I would like the attachment deleted. I am trying to get this done in a rule but maybe not the right way to go about it?

[mvidas]

Hi adenter,

Welcome to vbax :) There is no built-in setting or way of using a rule to do this, although outlook2003 allows you to use custom VBA scripts in rules which could do it. Do any of the defined Rules options allow you to identify your message?

You could use also VBA to do this a couple ways. However with newer versions of outlook you'll encounter a security popup (though there are free programs/addins that can take care of that for you)
You could either use the _NewMail event to loop through messages in a folder looking for messages with an .xml attachment, then process it.
You could also use the _ItemAdd event of a folder's .Items object. This is probably the better way of the two. You could try this by putting the following code into your ThisOutlookSession of your vbaproject.otm file:Option Explicit
Dim WithEvents xFold As Items
Private Sub xFold_ItemAdd(ByVal Item As Object)
Dim Atch As Attachment, vFF As Long, tStr As String, tmpFile As String
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count = 0 Then Exit Sub
With Item
tmpFile = "C:\xxxTEMPFILExxx.xml"
For Each Atch In .Attachments
If LCase(Right(Atch.FileName, 4)) = ".xml" Then
Atch.SaveAsFile tmpFile
vFF = FreeFile
Open tmpFile For Binary As #vFF
tStr = Space$(LOF(vFF))
Get #vFF, , tStr
Close #vFF
If Len(.HTMLBody) > 0 Then
.HTMLBody = .HTMLBody & "<br><br>" & tStr
Else
.Body = .Body & vbCrLf & vbCrLf & tStr
End If
Atch.Delete
Kill tmpFile
.Save
End If
Next 'Atch
End With
End Sub
Private Sub Application_Startup()
Set xFold = Application.Session.GetDefaultFolder(olFolderInbox).Folders("folder name").Items
End Sub
Private Sub Application_Quit()
Set xFold = Nothing
End Sub
Private Sub Application_NewMail()
If xFold Is Nothing Then
Set xFold = Application.Session.GetDefaultFolder(olFolderInbox).Folders("folder name").Items
End If
End SubSet the folder that you're going to want to look through (currently I have it as a subfolder of the inbox called "folder name").

Note that this is untested, but it should work fine. It is possible I made a slight typo in there. When a new message is received in the specified folder, it checks to see if there are any attachments. If there are, it loops through them to see if the mailitem has any attachments. if it does, it checks to see if the extention is .xml. If it is, it saves the file to a temporary file on your hard drive, loads up the file contents into a string variable, appends that to either the htmlbody or the body (depending on the format) of the mailitem object, then deletes the temporary file and attachment.

For the security thing, if you get it, check out a program called ClickYes. There is also a COM addin somewhere for outlook that does the same thing, though I don't have a link to that handy.

Matt

[adenter]

thanks for the reply. I have it in the VB editor and saved then restarted Outlook. I replaced the folder name with the subfolder. Not seeing the popup to indicate to me that the script is running. I am sure I have done something wrong but will investigate.

[mvidas]

Hmm.. it sounds like you did the right thing..? If you're using an earlier version of outlook then you wouldn't have a security popup.

A couple thoughts.. do you have macros enabled? (Tools / Macro / Security from outlook)
Did you put the code into the ThisOutlookSession object, and not just a normal module?
Assuming both of those are 'yes', you could put a msgbox into the _ItemAdd function.. insert this msgbox after the preceeding line:If TypeName(Item) <> "MailItem" Then Exit Sub
MsgBox "Checking Message with subject '" & Item.Subject & "'"That will tell you that it is being checked.
You could also put a stop point in there (either F9 to create a break point, or add the line "Stop" somewhere in there), and step through from that point on to see where it is progressing

[adenter]

Thanks very much. We have success! Let me figure out how to mark this solved.

[mvidas]

Glad to hear it!
To mark it solved, go to Thread Tools at the top of the page, and choose Mark Thread Solved. Let me know if you need anything else with this! :)
Matt

[adenter]

I just thought I would add a little to this. After a couple of iterations I have this set to run as a rule fired script. It does require outlook to be open but for my application it works perfectly. This iteration uses the MSXML2 reference. It takes the XML file that comes from a Cisco MARS appliance and reformats the message with the included information in the body of the text. This was necessary for my auto-ticket generator to work. My support model uses a centralized ticketing system and not the system included on the MARS appliance. So here is the code I have with no guarantees if it helps then great. I wanted to give back since mvidas was so great in helping me get started.

Also I wanted to see if I could post using the vba tags :)



Sub CollapseXMLtoBody(Item As Outlook.MailItem)
Dim Atch As Attachment, vFF As Long, tStr As String, bStr As String, lnStr As String, tmpFile As String, xmlDoc As New DOMDocument, incID As IXMLDOMElement, x As IXMLDOMNode
Dim sNode As String, inl As IXMLDOMNodeList

If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count = 0 Then Exit Sub
With Item
tmpFile = "C:\xxxTEMPFILExxx.xml"
For Each Atch In .Attachments
If LCase(Right(Atch.FileName, 4)) = ".xml" Then
Atch.SaveAsFile tmpFile
vFF = FreeFile
Open tmpFile For Binary As #vFF
tStr = Space$(LOF(vFF))
Get #vFF, , tStr
Close #vFF
xmlDoc.async = False
If xmlDoc.loadXML(tStr) Then
Set incID = xmlDoc.documentElement

Rem This line updates the Subject line and deletes MEDIUM or LOW events
If incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text = "HIGH" Then
Item.Subject = incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text & " " & Item.Subject
Else
Item.Subject = Item.Subject & "PROCESSED"
Item.Delete
Exit Sub
End If

Rem This is the first line of the body text
bStr = bStr & "IncidentID:" & incID.childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & vbCrLf & vbCrLf

Rem This is the second line of the body text
bStr = bStr & "Hostname:" & incID.childNodes.Item(0).childNodes.Item(4).Text & vbCrLf & vbCrLf

Rem This is the rules area of the body text
Set inl = incID.getElementsByTagName("Rule")
For i = 0 To (inl.Length - 1)
bStr = bStr & "UniqueID:" & incID.childNodes.Item(0).childNodes.Item(4).Text & "-" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & "RuleID:" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(0).Text & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(1).Text & vbCrLf & vbCrLf
Next

Rem This is the detail information section
Set inl = incID.getElementsByTagName("Session")
For i = 0 To (inl.Length - 1)
bStr = bStr & "Session:" & inl.Item(i).Attributes(0).nodeValue & vbTab
bStr = bStr & "Source:" & inl.Item(i).childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(2).Text & ")" & vbTab
bStr = bStr & "Destination:" & inl.Item(i).childNodes.Item(1).childNodes.Item(1).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(3).Text & ")" & vbTab
bStr = bStr & "IP Protocol #:" & inl.Item(i).childNodes.Item(1).childNodes.Item(4).Text & vbCrLf
Next

bStr = bStr & vbCrLf & "StartTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(0).Text & vbCrLf
bStr = bStr & "EndTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(1).Text & vbCrLf & vbCrLf

Item.Body = bStr
Else
Item.Body = "XML DIDN'T WORK"
End If

Rem unremark the following line if the attachements should be deleted
Rem Atch.Delete
Kill tmpFile
Item.Save
End If
Next 'Atch
End With
End Sub

[adenter]

Sub CollapseXMLtoBody(Item As Outlook.MailItem)
Dim Atch As Attachment, vFF As Long, tStr As String, bStr As String, lnStr As String, tmpFile As String, xmlDoc As New DOMDocument, incID As IXMLDOMElement, x As IXMLDOMNode
Dim sNode As String, inl As IXMLDOMNodeList

If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count = 0 Then Exit Sub
With Item
tmpFile = "C:\xxxTEMPFILExxx.xml"
For Each Atch In .Attachments
If LCase(Right(Atch.FileName, 4)) = ".xml" Then
Atch.SaveAsFile tmpFile
vFF = FreeFile
Open tmpFile For Binary As #vFF
tStr = Space$(LOF(vFF))
Get #vFF, , tStr
Close #vFF
xmlDoc.async = False
If xmlDoc.loadXML(tStr) Then
Set incID = xmlDoc.documentElement

Rem This line updates the Subject line and deletes MEDIUM or LOW events
If incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text = "HIGH" Then
Item.Subject = incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text & " " & Item.Subject
Else
Item.Subject = Item.Subject & "PROCESSED"
Item.Delete
Exit Sub
End If

Rem This is the first line of the body text
bStr = bStr & "IncidentID:" & incID.childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & vbCrLf & vbCrLf

Rem This is the second line of the body text
bStr = bStr & "Hostname:" & incID.childNodes.Item(0).childNodes.Item(4).Text & vbCrLf & vbCrLf

Rem This is the rules area of the body text
Set inl = incID.getElementsByTagName("Rule")
For i = 0 To (inl.Length - 1)
bStr = bStr & "UniqueID:" & incID.childNodes.Item(0).childNodes.Item(4).Text & "-" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & "RuleID:" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(0).Text & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(1).Text & vbCrLf & vbCrLf
Next

Rem This is the detail information section
Set inl = incID.getElementsByTagName("Session")
For i = 0 To (inl.Length - 1)
bStr = bStr & "Session:" & inl.Item(i).Attributes(0).nodeValue & vbTab
bStr = bStr & "Source:" & inl.Item(i).childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(2).Text & ")" & vbTab
bStr = bStr & "Destination:" & inl.Item(i).childNodes.Item(1).childNodes.Item(1).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(3).Text & ")" & vbTab
bStr = bStr & "IP Protocol #:" & inl.Item(i).childNodes.Item(1).childNodes.Item(4).Text & vbCrLf
Next

bStr = bStr & vbCrLf & "StartTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(0).Text & vbCrLf
bStr = bStr & "EndTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(1).Text & vbCrLf & vbCrLf

Item.Body = bStr
Else
Item.Body = "XML DIDN'T WORK"
End If

Rem unremark the following line if the attachements should be deleted
Rem Atch.Delete
Kill tmpFile
Item.Save
End If
Next 'Atch
End With
End Sub

[adenter]

With vba tag goodness!


file:///C:/DOCUME%7E1/adenter/LOCALS%7E1/Temp/moz-screenshot.jpgSub CollapseXMLtoBody(Item As Outlook.MailItem)
Dim Atch As Attachment, vFF As Long, tStr As String, bStr As String, lnStr As String, tmpFile As String, xmlDoc As New DOMDocument, incID As IXMLDOMElement, x As IXMLDOMNode
Dim sNode As String, inl As IXMLDOMNodeList

If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count = 0 Then Exit Sub
With Item
tmpFile = "C:\xxxTEMPFILExxx.xml"
For Each Atch In .Attachments
If LCase(Right(Atch.FileName, 4)) = ".xml" Then
Atch.SaveAsFile tmpFile
vFF = FreeFile
Open tmpFile For Binary As #vFF
tStr = Space$(LOF(vFF))
Get #vFF, , tStr
Close #vFF
xmlDoc.async = False
If xmlDoc.loadXML(tStr) Then
Set incID = xmlDoc.documentElement

Rem This line updates the Subject line and deletes MEDIUM or LOW events
If incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text = "HIGH" Then
Item.Subject = incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(2).Text & " " & Item.Subject
Else
Item.Subject = Item.Subject & "PROCESSED"
Item.Delete
Exit Sub
End If

Rem This is the first line of the body text
bStr = bStr & "IncidentID:" & incID.childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & vbCrLf & vbCrLf

Rem This is the second line of the body text
bStr = bStr & "Hostname:" & incID.childNodes.Item(0).childNodes.Item(4).Text & vbCrLf & vbCrLf

Rem This is the rules area of the body text
Set inl = incID.getElementsByTagName("Rule")
For i = 0 To (inl.Length - 1)
bStr = bStr & "UniqueID:" & incID.childNodes.Item(0).childNodes.Item(4).Text & "-" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & "RuleID:" & inl.Item(i).Attributes(0).nodeValue & vbCrLf & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(0).Text & vbCrLf
bStr = bStr & inl.Item(i).childNodes.Item(1).Text & vbCrLf & vbCrLf
Next

Rem This is the detail information section
Set inl = incID.getElementsByTagName("Session")
For i = 0 To (inl.Length - 1)
bStr = bStr & "Session:" & inl.Item(i).Attributes(0).nodeValue & vbTab
bStr = bStr & "Source:" & inl.Item(i).childNodes.Item(1).childNodes.Item(0).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(2).Text & ")" & vbTab
bStr = bStr & "Destination:" & inl.Item(i).childNodes.Item(1).childNodes.Item(1).Attributes(0).nodeValue & "("
bStr = bStr & inl.Item(i).childNodes.Item(1).childNodes.Item(3).Text & ")" & vbTab
bStr = bStr & "IP Protocol #:" & inl.Item(i).childNodes.Item(1).childNodes.Item(4).Text & vbCrLf
Next

bStr = bStr & vbCrLf & "StartTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(0).Text & vbCrLf
bStr = bStr & "EndTime:" & incID.childNodes.Item(1).childNodes.Item(0).childNodes.Item(1).Text & vbCrLf & vbCrLf

Item.Body = bStr
Else
Item.Body = "XML DIDN'T WORK"
End If

Rem unremark the following line if the attachements should be deleted
Rem Atch.Delete
Kill tmpFile
Item.Save
End If
Next 'Atch
End With
End Sub

[adenter]

disregard the image tag reference. sorry