␡
- 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
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.