Home > Articles > Home & Office Computing

  • Print
  • + Share This
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.

  • + Share This
  • 🔖 Save To Your Account