The Coding Hut

It’s been a while since my last posting, and I according to my site stats, my 4 readers must be getting impatient for new material. Recently I got an HTC 8525 PocketPC. Now, I use personal folders in Outlook, so all of my calendar appointments are in there and not on the Exchange server. Being that ActiveSync is created by MicroSloth, we’re at version 4 and still do not have the ability to specify where we are synching to, for users with multiple data files. After quite a lot of searching, I found a number of applications to synch my local calendar with the server, but all were shareware or quite flaky actually. So, when in need, roll your own!

The VBA should be pretty straight forward.. I am in a rush currently, so I am posting only the source right now. I will put more of a write-up and explain it a bit more as soon as I am able to.

Dim objOutlook

Dim objNameSpace

Dim objCalendarFolderSrc

Dim objCalendarFolderDest

Dim objItemsSrc

Dim objItemsDest

Dim ObjApptsSrc

Dim intMode

Const olFolderCalendar = 9
Const olAppointmentItem = 1   

Sub CopyAppointments()   

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")

MsgBox "Choose the source calendar"

Set objCalendarFolderSrc = objNameSpace.PickFolder   

If (objCalendarFolderSrc Is Nothing) 

  Then End

While objCalendarFolderSrc.DefaultItemType <> olAppointmentItem
    MsgBox "You did not select a calendar. Try again."

Set objCalendarFolderSrc = objNameSpace.PickFolder
If (objCalendarFolderSrc Is Nothing) 

  Then End

Wend   

MsgBox "Choose the destination calendar"

Set objCalendarFolderDest = objNameSpace.PickFolder   

If (objCalendarFolderDest Is Nothing) 

  Then End   

While objCalendarFolderDest.DefaultItemType <> olAppointmentItem
    MsgBox "You did not select a calendar. Try again."
    Set objCalendarFolderDest = objNameSpace.PickFolder
    If (objCalendarFolderDest Is Nothing) Then End
Wend     

Set objItemsSrc = objCalendarFolderSrc.Items
Set objItemsDest = objCalendarFolderSrc.Items   

Dim x
Dim i   

intMode = 5

If objItemsDest.Count < 1 Then 

  intMode = 4   

If (intMode = 4) Then
  For x = 1 To objItemsSrc.Count
    Set ObjApptsSrc = objItemsSrc.Item(x).Copy
    ObjApptsSrc.Move objCalendarFolderDest
  Next
End If   

If (intMode = 5) Then
  For x = 1 To objItemsSrc.Count
     For i = objItemsDest.Count To 1 Step -1
        If objItemsSrc.Item(x).Start = objItemsDest.Item(i).Start Then
          objItemsDest.Item(i).Delete
          Set objItemsDest = objCalendarFolderDest.Items
        End If
     Next
  Next   

  For x = 1 To objItemsSrc.Count
    Set ObjApptsSrc = objItemsSrc.Item(x).Copy
    ObjApptsSrc.Move objCalendarFolderDest
  Next
End If   

MsgBox "Complete."   

Set objNameSpace = Nothing
Set objOutlook = Nothing
Set objCalendarFolderSrc = Nothing
Set objCalendarFolderDest = Nothing
Set objItemsSrc = Nothing
Set objItemsDest = Nothing
Set ObjApptsSrc = Nothing   

End Sub

Enjoy!