␡
- Finding the Best Hacks
- Hacking Your Way Out of Outlook
- Extending the Outlook Hack
- Refining the Code for Even Better Results
- Wrapping Up
Like this article? We recommend
Like this article? We recommend
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.