Sub ContactsToXML()
Dim xmlHeader As String
Dim olApp As Outlook.Application
Dim objName As NameSpace
Dim Folder As MAPIFolder
Dim objContact As Variant
'Dim objContact As Outlook.ContactItem
Dim objMailItem As Outlook.MailItem
Dim objAppointment As Outlook.AppointmentItem
Dim i As Integer


Set olApp = Outlook.Application
Set objName = olApp.GetNamespace("MAPI")
Set Folder = objName.GetDefaultFolder(olFolderContacts)
'Set Folder = Folder.Folders.Item(2)


Open "C:\contacts.xml" For Output As #1

Print #1, ""
'Print #1, ""
'Print #1, ""

On Error Resume Next

For Each Item In Folder.Items

Set objAppointment = Item
Print #1, " "

Call PrintXMLElement("FullName", Item.FullName)
Call PrintXMLElement("FirstName", Item.FirstName)
Call PrintXMLElement("LastName", Item.LastName)
Call PrintXMLElement("BusinessPhone", Item.BusinessTelephoneNumber)
Call PrintXMLElement("Department", Item.Department)
Call PrintXMLElement("Categories", Item.Categories)
Call PrintXMLElement("EmailAddress", Item.Email1Address)

If Len(Item.Body) > 0 Then
Print #1, " "
End If

Print #1, " "
Next Item

Print #1, ""

Close #1

End Sub