sloppycode.net
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
{Name}
Says:
{Date}
{Text}
› Home
› C#
› Snippets
› Articles
› Tools
› Taglines
› ASP
› Dictionary Object
› FSO
› Unix cheat sheet
› Gaming
› CSS
› Yak
› Umbraco
› About
› Contact
› Privacy
› Projects
› Search
› Sitemap
Buy on Amazon
Buy on Amazon
Buy on Amazon
Buy on Amazon