␡
- 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
Refining the Code for Even Better Results
Now let's streamline this code to export even more data. More importantly, we'll set up the Outlook script to look for the iPod without having to specify its location.
First, create a new module with the name iPodExporter. Then add the following lengthy code (I suggest cut and paste), which will give you all you need:
Option Explicit ' ' Software locates the iPod drive by finding removable media ' containing the folder 'contacts' ' Then all existing files in contacts and calendar folders ' will be deleted ' All contacts will be exported ' All notes will be exported as contacts with a preceding '!' ' All calendar items will be exported. Recurring items will ' appear actual, last and next year ' ' System routines ' Drive Types Private Const DRIVE_UNKNOWN = 0 Private Const DRIVE_ABSENT = 1 Private Const DRIVE_REMOVABLE = 2 Private Const DRIVE_FIXED = 3 Private Const DRIVE_REMOTE = 4 Private Const DRIVE_CDROM = 5 Private Const DRIVE_RAMDISK = 6 Private LW$(26), AnzahlLW% Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _ "WNetGetConnectionA" (ByVal lpszLocalName As String, _ ByVal lpszRemoteName As String, cbRemoteName As Long) As Long Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _ "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _ ByVal lpBuffer As String) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long ' Main Export routine ' Sub ExportContactsToIpod() Dim IPOD_Path As String Dim i As Long Dim mynamespace As Object Dim myfolder As Object Dim sName As String Dim Pos As Long Dim NumItems As Long Dim Checkday As AppointmentItem Dim d As Long Dim ThisDay As Date Dim ThisDayEnd As Date Dim CalCnt As Long ' Locate IPODDrive If sFindIPOD = "" Then MsgBox "iPod not found!", vbCritical Or vbOKOnly, "No iPod" Exit Sub End If ' Show Dialog iPodExport.DriveLabel.Caption = sFindIPOD iPodExport.ProgressBar.Width = 0 ' Max 219 iPodExport.Show False DoEvents ' Paint the form ' Clear all existing files! On Error Resume Next IPOD_Path = sFindIPOD Kill IPOD_Path & "Contacts\*.*" Kill IPOD_Path & "Calendars\*.*" ' Export all contacts as .vcf Set mynamespace = Application.GetNamespace("MAPI") Set myfolder = mynamespace.GetDefaultFolder(10) ' Contacts NumItems = myfolder.Items.Count Set myfolder = mynamespace.GetDefaultFolder(12) ' Notes NumItems = NumItems + myfolder.Items.Count Set myfolder = mynamespace.GetDefaultFolder(9) ' CalendarItems NumItems = NumItems + myfolder.Items.Count Set myfolder = mynamespace.GetDefaultFolder(10) For i = 1 To myfolder.Items.Count 'Preset filename with last name, company name, or 'Address' DoEvents ' Paint the form sName = myfolder.Items(i).LastName If sName = "" Then sName = myfolder.Items(i).CompanyName End If If sName = "" Then sName = "Address" End If ' Export Address to iPod Pos = Pos + 1 myfolder.Items(i).SaveAs IPOD_Path & "Contacts\" & sName & "_" & i & ".vcf", olVCard iPodExport.ProgressBar.Width = 219 * Pos / NumItems Next i ' Export all notes as vcf Set myfolder = mynamespace.GetDefaultFolder(12) For i = 1 To myfolder.Items.Count 'Preset title with subject or 'Note xx' DoEvents ' Paint the form sName = myfolder.Items(i).Subject If sName = "" Then sName = "Note " & i End If ' Write VCard manually Open IPOD_Path & "Contacts\Note_" & i & ".vcf" For Output As 1 Print #1, "BEGIN:VCARD" Print #1, "N:!" & sName ' Notes begin with '!' Print #1, "NOTE;ENCODING=QUOTED-PRINTABLE:" & ConvertedMsg(myfolder.Items(i).Body) Print #1, "END:VCARD" Close #1 Pos = Pos + 1 iPodExport.ProgressBar.Width = 219 * Pos / NumItems Next i ' Export calendar items Set myfolder = mynamespace.GetDefaultFolder(9) Dim appitem As AppointmentItem For i = 1 To myfolder.Items.Count DoEvents ' Paint the form ' Export calendar item to iPod Pos = Pos + 1 Set appitem = myfolder.Items(i) Set Checkday = Nothing ' If recurring event, check from beginning of last year to end of next year... If appitem.IsRecurring Then ThisDay = DateValue(Format(appitem.Start, "dd.mm." & Year(Now))) + TimeValue(Format(appitem.Start, "hh:mm:ss")) ThisDayEnd = DateValue(Format(appitem.End, "dd.mm." & Year(Now))) + TimeValue(Format(appitem.End, "hh:mm:ss")) For d = DateDiff("d", Now, DateValue("01.01." & Year(Now) - 1)) To DateDiff("d", Now, DateValue("31.12." & Year(Now) + 1)) Set Checkday = appitem.GetRecurrencePattern.GetOccurrence(DateAdd("d", d, ThisDay)) If Not Checkday Is Nothing Then ' Write VCard manually CalCnt = CalCnt + 1 Open IPOD_Path & "Calendars\Cal_" & CalCnt & ".vcs" For Output As 1 Print #1, "BEGIN:VCALENDAR" Print #1, "BEGIN:VEVENT" Print #1, "DESCRIPTION;ENCODING=QUOTED-PRINTABLE:" & ConvertedMsg(appitem.Body) Print #1, "SUMMARY;ENCODING=QUOTED-PRINTABLE:" & ConvertedMsg(appitem.Subject) Print #1, "DTSTART:" & DT(DateAdd("d", d, ThisDay)) Print #1, "DTEND:" & DT(DateAdd("d", d, ThisDayEnd)) Print #1, "END:VEVENT" Print #1, "END:VCALENDAR" Close #1 Set Checkday = Nothing End If Next d Else ' else normal appointment ' Write VCard manually CalCnt = CalCnt + 1 Open IPOD_Path & "Calendars\Cal_" & CalCnt & ".vcs" For Output As 1 Print #1, "BEGIN:VCALENDAR" Print #1, "BEGIN:VEVENT" Print #1, "DESCRIPTION;ENCODING=QUOTED-PRINTABLE:" & ConvertedMsg(appitem.Body) Print #1, "SUMMARY;ENCODING=QUOTED-PRINTABLE:" & ConvertedMsg(appitem.Subject) Print #1, "DTSTART:" & DT(appitem.Start) Print #1, "DTEND:" & DT(appitem.End) Print #1, "END:VEVENT" Print #1, "END:VCALENDAR" Close #1 End If iPodExport.ProgressBar.Width = 219 * Pos / NumItems Next i ' Release drive ChDrive "H:\" ' Hide dialog iPodExport.Hide ' It's done End Sub ' Locates an iPod by its contacts folder Private Function sFindIPOD() As String Dim strAllDrives As String Dim strTmp As String On Error Resume Next strAllDrives = fGetDrives If strAllDrives <> "" Then Do strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1) strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1) If Left$(fDriveType(strTmp), 5) = "Remov" And strTmp <> "A:\" And strTmp <> "B:\" Then ChDrive strTmp ChDir strTmp & "Contacts\" If CurDir = strTmp & "Contacts" Then sFindIPOD = strTmp Exit Function End If End If Loop While strAllDrives <> "" End If End Function Private Function fGetDrives() As String 'Returns all mapped drives Dim lngRet As Long Dim strDrives As String * 255 Dim lngTmp As Long lngTmp = Len(strDrives) lngRet = GetLogicalDriveStrings(lngTmp, strDrives) fGetDrives = Left(strDrives, lngRet) End Function Private Function fDriveType(strDriveName As String) As String Dim lngRet As Long Dim strDrive As String lngRet = GetDriveType(strDriveName) Select Case lngRet Case DRIVE_UNKNOWN 'The drive type cannot be determined. strDrive = "Unknown Drive Type" Case DRIVE_ABSENT 'The root directory does not exist. strDrive = "Drive does not exist" Case DRIVE_REMOVABLE 'This detects a removable drive. strDrive = "Removable Media" Case DRIVE_FIXED 'The disk cannot be removed from the drive. strDrive = "Fixed Drive" Case DRIVE_REMOTE 'The drive is a remote (network) drive. strDrive = "Network Drive" Case DRIVE_CDROM 'The drive is a CD-ROM drive. strDrive = "CD Rom" Case DRIVE_RAMDISK 'The drive is a RAM disk. strDrive = "Ram Disk" End Select fDriveType = strDrive End Function Function ConvertedMsg(sText As String) As String Dim i As Long For i = 1 To Len(sText) Select Case Asc(Mid$(sText, i, 1)) Case 13 ConvertedMsg = ConvertedMsg & "=0D" Case 10 ConvertedMsg = ConvertedMsg & "=0A" Case 59 ConvertedMsg = ConvertedMsg & "\;" Case Else ConvertedMsg = ConvertedMsg & Mid$(sText, i, 1) End Select Next i End Function Function DT(dDate As Date) As String Dim num As String num = Year(dDate) If Len(num) < 4 Then num = String(4 - Len(num), "0") & num DT = DT & num num = Month(dDate) If Len(num) < 2 Then num = String(2 - Len(num), "0") & num DT = DT & num num = Day(dDate) If Len(num) < 2 Then num = String(2 - Len(num), "0") & num DT = DT & num DT = DT & "T" num = Hour(dDate) If Len(num) < 2 Then num = String(2 - Len(num), "0") & num DT = DT & num num = Minute(dDate) If Len(num) < 2 Then num = String(2 - Len(num), "0") & num DT = DT & num num = Second(dDate) If Len(num) < 2 Then num = String(2 - Len(num), "0") & num DT = DT & num End Function
The only thing left to do is run the macro. You'll need to change your macro settings to Medium for this code to run.
There's no reason why you can't import RSS data, weather from a web service, or any other data you want to have on your iPod. Click the macro and you have all the information you need.