outlookexport

Outlook export
Exports all Outlook inbox, contacts, appointments to an XML file.

Home
›
Code snippets
›
Misc
›
Outlook export

Exports your Oulook inbox, contacts, appointments to XML.

Option Explicit

Sub ImportAppointmentsFromXml()
    Dim absoluteFilename As String
    absoluteFilename = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myAppointments.xml) to import.")
    If absoluteFilename = Null Or Len(absoluteFilename) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Set xmlDoc = New DOMDocument
    xmlDoc.Load (absoluteFilename)
    
    Dim appointmentNodeList As IXMLDOMNodeList
    Set appointmentNodeList = xmlDoc.getElementsByTagName("appointment")
        
    Dim objAppointment As Outlook.AppointmentItem
    Dim currentAppointmentNode As IXMLDOMNode
    Set currentAppointmentNode = appointmentNodeList.NextNode
    Do Until currentAppointmentNode Is Nothing
        Set objAppointment = Application.CreateItem(olAppointmentItem)
        objAppointment.Subject = currentAppointmentNode.selectSingleNode("subject").Text
        objAppointment.Location = currentAppointmentNode.selectSingleNode("location").Text
        objAppointment.Start = currentAppointmentNode.selectSingleNode("startdate").Text
        objAppointment.End = currentAppointmentNode.selectSingleNode("enddate").Text
        objAppointment.AllDayEvent = currentAppointmentNode.selectSingleNode("@alldayevent").Text
        objAppointment.Duration = currentAppointmentNode.selectSingleNode("duration").Text
        objAppointment.Importance = currentAppointmentNode.selectSingleNode("@importance").Text
        objAppointment.Sensitivity = currentAppointmentNode.selectSingleNode("@sensitivity").Text
        objAppointment.Body = currentAppointmentNode.selectSingleNode("contents").Text
        objAppointment.Save
        Set currentAppointmentNode = appointmentNodeList.NextNode
    Loop

End Sub

Sub ImportContactsFromXml()
    Dim absoluteFilename As String
    absoluteFilename = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myContacts.xml) to import.")
    If absoluteFilename = Null Or Len(absoluteFilename) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Set xmlDoc = New DOMDocument
    xmlDoc.Load (absoluteFilename)
    
    Dim contactNodeList As IXMLDOMNodeList
    Set contactNodeList = xmlDoc.getElementsByTagName("contact")
    Dim objContact As Outlook.ContactItem
    Dim currentContactNode As IXMLDOMNode
    Set currentContactNode = contactNodeList.NextNode
    Do Until currentContactNode Is Nothing
        ' Code to retrieve contact items from the XML
        Set objContact = Application.CreateItem(olContactItem)
        objContact.FirstName = currentContactNode.selectSingleNode("firstname").Text
        objContact.LastName = currentContactNode.selectSingleNode("lastname").Text
        objContact.JobTitle = currentContactNode.selectSingleNode("jobtitle").Text
        objContact.CompanyName = currentContactNode.selectSingleNode("company").Text
        objContact.MobileTelephoneNumber = currentContactNode.selectSingleNode("mobiletelephone").Text
        objContact.HomeAddress = currentContactNode.selectSingleNode("home/address").Text
        objContact.HomeAddressStreet = currentContactNode.selectSingleNode("home/street").Text
        objContact.HomeAddressCity = currentContactNode.selectSingleNode("home/city").Text
        objContact.HomeAddressState = currentContactNode.selectSingleNode("home/state").Text
        objContact.HomeAddressCountry = currentContactNode.selectSingleNode("home/country").Text
        objContact.HomeTelephoneNumber = currentContactNode.selectSingleNode("home/telephone").Text
        objContact.BusinessAddress = currentContactNode.selectSingleNode("business/address").Text
        objContact.BusinessAddressStreet = currentContactNode.selectSingleNode("business/street").Text
        objContact.BusinessAddressCity = currentContactNode.selectSingleNode("business/city").Text
        objContact.BusinessAddressState = currentContactNode.selectSingleNode("business/state").Text
        objContact.BusinessAddressCountry = currentContactNode.selectSingleNode("business/country").Text
        objContact.BusinessTelephoneNumber = currentContactNode.selectSingleNode("business/telephone").Text
        objContact.Save
        Set currentContactNode = contactNodeList.NextNode
    Loop
End Sub

Sub ImportNotesFromXml()
    Dim absoluteFilename As String
    absoluteFilename = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myNotes.xml) to import.")
    If absoluteFilename = Null Or Len(absoluteFilename) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Set xmlDoc = New DOMDocument
    xmlDoc.Load (absoluteFilename)
    
    Dim noteNodeList As IXMLDOMNodeList
    Set noteNodeList = xmlDoc.getElementsByTagName("note")
        
    Dim objNote As Object
    Dim currentNoteNode As IXMLDOMNode
    
    Set currentNoteNode = noteNodeList.NextNode
    Do Until currentNoteNode Is Nothing
        Set objNote = Application.CreateItem(olNoteItem)
        objNote.Body = currentNoteNode.selectSingleNode("subject").Text + Chr(10) + currentNoteNode.selectSingleNode("contents").Text
        objNote.Save
        Set currentNoteNode = noteNodeList.NextNode
    Loop
End Sub

Sub CopyAppoinmentsToXml()
    Dim dirLocation As String
    dirLocation = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myContacts.xml). The exported XML file will be written to this location.")
    If dirLocation = Null Or Len(dirLocation) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Dim xmlNode As IXMLDOMNode
    Dim xmlAttribute As IXMLDOMAttribute
    Dim xmlAppointments As IXMLDOMNode
    Dim xmlPi As IXMLDOMProcessingInstruction
    Set xmlDoc = New DOMDocument

Set xmlPi = xmlDoc.createProcessingInstruction("xml", "version=""1.0""")
    Set xmlNode = xmlDoc.appendChild(xmlPi)
    Set xmlAppointments = xmlDoc.createElement("appointments")
    Set xmlNode = xmlDoc.appendChild(xmlAppointments)

Dim objApplication As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objAppointments As Outlook.MAPIFolder
    Dim objAppointment As Outlook.AppointmentItem
    Dim appointmentIndex As Integer

Set objApplication = CreateObject("Outlook.Application")
    Set objNameSpace = objApplication.GetNamespace("MAPI")
    Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)

Dim xmlAppointment As IXMLDOMNode
    Dim xmlText As IXMLDOMText

For appointmentIndex = 1 To objAppointments.Items.Count
        Set objAppointment = objAppointments.Items.item(appointmentIndex)
        Set xmlAppointment = xmlDoc.createElement("appointment")
        
        Set xmlNode = xmlDoc.createElement("subject")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Subject))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("location")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Location))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("startdate")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Start))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("enddate")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.End))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlAttribute = xmlDoc.createAttribute("alldayevent")
        Set xmlText = xmlAttribute.appendChild(xmlDoc.createTextNode(objAppointment.AllDayEvent))
        Set xmlNode = xmlAppointment.Attributes.setNamedItem(xmlAttribute)
        
        Set xmlNode = xmlDoc.createElement("duration")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Duration))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("organizer")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Organizer))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlAttribute = xmlDoc.createAttribute("importance")
        Set xmlText = xmlAttribute.appendChild(xmlDoc.createTextNode(objAppointment.Importance))
        Set xmlNode = xmlAppointment.Attributes.setNamedItem(xmlAttribute)
        
        Set xmlAttribute = xmlDoc.createAttribute("sensitivity")
        Set xmlText = xmlAttribute.appendChild(xmlDoc.createTextNode(objAppointment.Sensitivity))
        Set xmlNode = xmlAppointment.Attributes.setNamedItem(xmlAttribute)
        
        Set xmlNode = xmlDoc.createElement("contents")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objAppointment.Body))
        Set xmlNode = xmlAppointment.appendChild(xmlNode)
        
        Set xmlAppointment = xmlAppointments.appendChild(xmlAppointment)
    Next

xmlDoc.Save (dirLocation)
    MsgBox "Outlook Appointments exported to XML"
End Sub

Sub CopyContactsToXml()
    Dim dirLocation As String
    dirLocation = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myContacts.xml). The exported XML file will be written to this location.")
    If dirLocation = Null Or Len(dirLocation) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Dim xmlNode As IXMLDOMNode
    Dim xmlContacts As IXMLDOMNode
    Dim xmlPi As IXMLDOMProcessingInstruction
    Set xmlDoc = New DOMDocument

Set xmlPi = xmlDoc.createProcessingInstruction("xml", "version=""1.0""")
    Set xmlNode = xmlDoc.appendChild(xmlPi)
    Set xmlContacts = xmlDoc.createElement("contacts")
    Set xmlNode = xmlDoc.appendChild(xmlContacts)

Dim objApplication As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objContacts As Outlook.MAPIFolder
    Dim objContact As Outlook.ContactItem
    Dim contactIndex As Integer

Set objApplication = CreateObject("Outlook.Application")
    Set objNameSpace = objApplication.GetNamespace("MAPI")
    Set objContacts = objNameSpace.GetDefaultFolder(olFolderContacts)

Dim xmlContact As IXMLDOMNode
    Dim xmlText As IXMLDOMText

For contactIndex = 1 To objContacts.Items.Count
        Set objContact = objContacts.Items.item(contactIndex)
        Set xmlContact = xmlDoc.createElement("contact")

Set xmlNode = xmlDoc.createElement("firstname")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.FirstName))
        Set xmlNode = xmlContact.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("lastname")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.LastName))
        Set xmlNode = xmlContact.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("jobtitle")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.JobTitle))
        Set xmlNode = xmlContact.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("company")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.CompanyName))
        Set xmlNode = xmlContact.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("mobiletelephone")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MobileTelephoneNumber))
        Set xmlNode = xmlContact.appendChild(xmlNode)

Dim xmlBusiness As IXMLDOMNode
        Set xmlBusiness = xmlDoc.createElement("business")
        Set xmlNode = xmlContact.appendChild(xmlBusiness)

Set xmlNode = xmlDoc.createElement("address")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddress))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("street")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddressStreet))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("city")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddressCity))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("state")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddressState))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("zipcode")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddressPostalCode))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("country")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessAddressCountry))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("telephone")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessTelephoneNumber))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("telephone2")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessTelephoneNumber2))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("fax")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.BusinessFaxNumber))
        Set xmlNode = xmlBusiness.appendChild(xmlNode)
        
        Dim xmlMailingAddress As IXMLDOMNode
        Set xmlBusiness = xmlDoc.createElement("mailing")
        Set xmlNode = xmlContact.appendChild(xmlBusiness)
        
        Set xmlNode = xmlDoc.createElement("address")
        Set xmlMailingAddress = xmlMailingAddress.appendChild(xmlDoc.createTextNode(objContact.MailingAddress))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("street")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MailingAddress))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("city")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MailingAddressCity))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("state")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MailingAddressCity))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)
        
        Set xmlNode = xmlDoc.createElement("zipcode")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MailingAddressPostalCode))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("country")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.MailingAddressCountry))
        Set xmlNode = xmlMailingAddress.appendChild(xmlNode)
        
        Dim xmlHome As IXMLDOMNode
        Set xmlHome = xmlDoc.createElement("home")
        Set xmlNode = xmlContact.appendChild(xmlHome)

Set xmlNode = xmlDoc.createElement("address")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeAddress))
        Set xmlNode = xmlHome.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("street")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeAddressStreet))
        Set xmlNode = xmlHome.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("city")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeAddressCity))
        Set xmlNode = xmlHome.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("state")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeAddressState))
        Set xmlNode = xmlHome.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("country")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeAddressCountry))
        Set xmlNode = xmlHome.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("telephone")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objContact.HomeTelephoneNumber))
        Set xmlNode = xmlHome.appendChild(xmlNode)
        
        Set xmlNode = xmlContacts.appendChild(xmlContact)
    Next

xmlDoc.Save (dirLocation)
    MsgBox "Outlook Contacts exported to XML"
End Sub

Sub CopyEmailsToXml()
    Dim dirLocation As String
    dirLocation = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myContacts.xml). The exported XML file will be written to this location.")
    If dirLocation = Null Or Len(dirLocation) = 0 Then
        Exit Sub
    End If
    Dim xmlDoc As DOMDocument
    Dim xmlNode As IXMLDOMNode
    Dim xmlEmails As IXMLDOMNode
    Dim xmlPi As IXMLDOMProcessingInstruction
    Set xmlDoc = New DOMDocument

Set xmlPi = xmlDoc.createProcessingInstruction("xml", "version=""1.0""")
    Set xmlNode = xmlDoc.appendChild(xmlPi)
    Set xmlEmails = xmlDoc.createElement("emails")
    Set xmlNode = xmlDoc.appendChild(xmlEmails)

Dim objApplication As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objEmails As Outlook.MAPIFolder
    Dim objEmail As Outlook.MailItem
    Dim emailIndex As Integer

Set objApplication = CreateObject("Outlook.Application")
    Set objNameSpace = objApplication.GetNamespace("MAPI")
    Set objEmails = objNameSpace.PickFolder
    ' Todo: Add code to check to see if objEmails is valid

Dim xmlEmail As IXMLDOMNode
    Dim xmlText As IXMLDOMText

For emailIndex = 1 To objEmails.Items.Count
        Set objEmail = objEmails.Items.item(emailIndex)
        Set xmlEmail = xmlDoc.createElement("email")

Set xmlNode = xmlDoc.createElement("sender")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objEmail.SenderName))
        Set xmlNode = xmlEmail.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("receivedtime")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objEmail.ReceivedTime))
        Set xmlNode = xmlEmail.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("subject")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objEmail.Subject))
        Set xmlNode = xmlEmail.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("message")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objEmail.Body))
        Set xmlNode = xmlEmail.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("htmlmessage")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objEmail.HTMLBody))
        Set xmlNode = xmlEmail.appendChild(xmlNode)
    
        Set xmlEmail = xmlEmails.appendChild(xmlEmail)
    Next

xmlDoc.Save (dirLocation)
    MsgBox "Outlook E-Mail Items exported to XML"
End Sub

Sub CopyNotesToXml()
    
    Dim dirLocation As String
    dirLocation = InputBox("Please enter an absolute directory location and filename (e.g., c:\temp\myContacts.xml). The exported XML file will be written to this location.")
    If dirLocation = Null Or Len(dirLocation) = 0 Then
        Exit Sub
    End If
    
    Dim xmlDoc As DOMDocument
    Dim xmlNode As IXMLDOMNode
    Dim xmlNotes As IXMLDOMNode
    Dim xmlPi As IXMLDOMProcessingInstruction
    Set xmlDoc = New DOMDocument

Set xmlPi = xmlDoc.createProcessingInstruction("xml", "version=""1.0""")
    Set xmlNode = xmlDoc.appendChild(xmlPi)
    Set xmlNotes = xmlDoc.createElement("notes")
    Set xmlNode = xmlDoc.appendChild(xmlNotes)

Dim objApplication As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objNotes As Outlook.MAPIFolder
    Dim objNote As Outlook.NoteItem
    Dim noteIndex As Integer

Set objApplication = CreateObject("Outlook.Application")
    Set objNameSpace = objApplication.GetNamespace("MAPI")
    Set objNotes = objNameSpace.GetDefaultFolder(olFolderNotes)

Dim xmlNote As IXMLDOMNode
    Dim xmlText As IXMLDOMText

For noteIndex = 1 To objNotes.Items.Count
        Set objNote = objNotes.Items.item(noteIndex)
        Set xmlNote = xmlDoc.createElement("note")
        
        Set xmlNode = xmlDoc.createElement("subject")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objNote.Subject))
        Set xmlNode = xmlNote.appendChild(xmlNode)

Set xmlNode = xmlDoc.createElement("contents")
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(objNote.Body))
        Set xmlNode = xmlNote.appendChild(xmlNode)
    
        Set xmlNode = xmlNotes.appendChild(xmlNote)
    Next

xmlDoc.Save (dirLocation)
    MsgBox "Outlook Notes exported to XML"
End Sub

Sub ExportAppointmentsToXml()
    Call CopyAppoinmentsToXml
End Sub

Sub ExportContactsToXml()
    Call CopyContactsToXml
End Sub

Sub ExportEmailToXml()
    Call CopyEmailsToXml
End Sub

Sub ExportNotesToXml()
    Call CopyNotesToXml
End Sub

' The purpose of this subroutine is handle cases where no field
' data exists.  This subroutine needs further debugging.
'
' Call XmlAppend(xmlDoc, xmlNode, objNote.Subject)
'
Sub XmlAppend(xmlDoc As DOMDocument, xmlNode As IXMLDOMNode, item As Variant)
    If Not item Then
        Dim xmlText As IXMLDOMText
        Set xmlText = xmlNode.appendChild(xmlDoc.createTextNode(item))
    End If
End Sub