Home > Articles > Home & Office Computing

  • Print
  • + Share This
Like this article? We recommend

Like this article? We recommend

Extending the Outlook Hack

Want to take this hack a bit further? Add the following code to bring over your email, contacts, notes, and calendar items:

Want to take this hack a bit further? The following code brings over your email, contacts, notes, and calendar items. Just replace the previous code with this new version (the principles are the same; we're just doing more):

'Change the next line to your export paths!
Const ContactsXPortPath As String = "H:\Contacts\"
Const CalendarXPortPath As String = "H:\Calendars\"
Const NotesXPortPath As String = "H:\Notes\Notes\"
Const EmailXPortPath As String = "H:\Notes\e-mail\"

Sub ExportAll()
ExportToVCard
ExportToiCalendar
ExportToText
ExportToEmail

MsgBox ("Export to iPod Complete")
End Sub

Sub ExportToVCard()
Dim ns As NameSpace
Dim fld As MAPIFolder
Dim itm
Dim itms As Items
Dim newFile
Set ns = Application.GetNamespace("MAPI")
Set fld = ns.GetDefaultFolder(olFolderContacts)
Set itms = fld.Items
itms.Sort "[LastName]", False

For Each itm In itms
If TypeName(itm) = "ContactItem" Then
newFile = cleanFileName(itm.LastNameAndFirstName)
itm.SaveAs ContactsXPortPath & newFile & ".vcf", olVCard
End If
Next itm

End Sub

Sub ExportToiCalendar()
Dim ns As NameSpace
Dim fld As MAPIFolder
Dim itm
Dim itms As Items
Dim newFile
Set ns = Application.GetNamespace("MAPI")
Set fld = ns.GetDefaultFolder(olFolderCalendar)
Set itms = fld.Items
itms.Sort "[Start]", False

For Each itm In itms
If TypeName(itm) = "AppointmentItem" Then
newFile = cleanFileName(itm.Subject)
itm.SaveAs CalendarXPortPath & newFile & ".ics", olICal
End If
Next itm

End Sub

Sub ExportToText()
Dim ns As NameSpace
Dim fld As MAPIFolder
Dim itm
Dim itms As Items
Dim newFile
Set ns = Application.GetNamespace("MAPI")
Set fld = ns.GetDefaultFolder(olFolderNotes)
Set itms = fld.Items
itms.Sort "[Subject]", False

For Each itm In itms
If TypeName(itm) = "NoteItem" Then
newFile = cleanFileName(itm.Subject)
itm.SaveAs NotesXPortPath & newFile & ".txt", olTXT
End If
Next itm

End Sub

Sub ExportToEmail()
Dim ns As NameSpace
Dim fld As MAPIFolder
Dim itm
Dim itms As Items
Dim newFile
Set ns = Application.GetNamespace("MAPI")
Set fld = ns.GetDefaultFolder(olFolderInbox)
Set itms = fld.Items
itms.Sort "[Subject]", False

For Each itm In itms
If TypeName(itm) = "MailItem" Then
newFile = cleanFileName(itm.Subject)
itm.SaveAs EmailXPortPath & newFile & ".txt", olTXT
End If
Next itm

End Sub

Function cleanFileName(dirtyFileName As String)
cleanFileName = dirtyFileName
cleanFileName = Replace(cleanFileName, ":", " ")
cleanFileName = Replace(cleanFileName, "/", " ")
cleanFileName = Replace(cleanFileName, "\", " ")
cleanFileName = Replace(cleanFileName, "?", " ")
cleanFileName = Replace(cleanFileName, "*", " ")
cleanFileName = Replace(cleanFileName, "|", " ")
cleanFileName = Replace(cleanFileName, "", " ")
cleanFileName = Replace(cleanFileName, Chr(34), " ")
cleanFileName = Replace(cleanFileName, Chr(9), " ")
End Function

NOTE

Thanks to Ty Anderson, the brains behind this code, for letting me use it for this article.

  • + Share This
  • 🔖 Save To Your Account