Windows LiveカレンダーをOutlookのデフォルトのカレンダーにバックアップ・同期するスクリプト

スケジュール管理をWindows Liveカレンダーに集約し、アンドロイド端末(Xperia mini pro）からExchange ActiveSyncで最新の状態に管理して1週間がたちました。
慣れれば何とかなるもの。
しばらく続けてみたいと思っています。
しかしそうなると、母艦のOutlookにあるデフォルトのカレンダーとの同期が問題になるわけです（私は）。
Outlook Hotmail Connectorを使えば、Windows LiveカレンダーとOutlook内にできるHotmail Connectorのカレンダーが同期されるのですが、
これまで使ってきたOutlookのデフォルトのカレンダーとの同期がどうしてもできないのです。

そこで、

Windows Liveカレンダーから（Outlook Hotmail Connector経由で）Outlookのデフォルトのカレンダーへの一方通行の同期を実行するスクリプトを作成しました。
Windows Liveカレンダーで新規作成・変更されたデータがOutlookのデフォルトのカレンダーに反映されるようなしろものです。
Windows Liveカレンダーを信用しないわけではないのですが、バックアップとしてOutlookのデフォルトのカレンダーを使えればなぁとか、もしかしたらまたOutlookのデフォルトのカレンダーに戻ってくるかもしれないなぁとか、そんなことを考えて作りました。

注意！

Outlookのデフォルトのカレンダーの修正がWindows Liveカレンダーにも反映させるような頭の良いスクリプトではありません。せっかくデフォルトのカレンダーで操作してもスクリプト走らせるとWindows Liveカレンダーと同じ状態になってしまいますので注意が必要。

準備

Outlookが導入されているのはもちろん、Outlook Hotmail Connectorをインストールしておいてください。
Outlook.com アカウントを Windows 版 Outlook に追加する - Outlook
Outlook Hotmail ConnectorがWindows Liveカレンダーと十分同期していることも確認しておいてください。すべてのアイテムがすぐ同期するようなことはないようなのです。徐々に同期するようです。
で、次のスクリプトをOutlookに仕込みます。仕込めない方はあきらめてください。
同期対象の期間は、スクリプト実行時の1週間前のアイテムから2か月後のアイテムまでです。
できればイミディエイトウィンドウは出していたほうがいいかも。
Debug.Print行はなくてもいいんですが、スクリプトの実行に時間がかかることがあって（WILLCOM D4なんかはやっぱり遅い！）、イミディエイトウィンドウに動作状況が見えるようにしたかったので入れているんです。それでもフリーズしたかのような動きをするときがありますが、問題なく動いていますので焦らずじっと待ってください。

Sub SyncWindowsLive()
    Dim colWLAppts As Items, colAppts As Items
    Dim objWLAppt, objAppt, objStartAppt
    Dim apptItem As AppointmentItem
    Dim strStart As String, strEnd As String, dtStart As Date, dtEnd As Date
    Dim f As Boolean
    
    Const strLiveId = "******@*******"  'Windows Live IDに修正
    Const strCalName = "******"         'Windows Liveカレンダー内でのカレンダー名称に修正

    Debug.Print "====="
    
    dtStart = DateAdd("d", -7, Now) '１週間くらい前から
    dtEnd = DateAdd("m", 2, Now) '２か月くらい後まで
    strStart = Year(dtStart) & "/" & Month(dtStart) & "/" & Day(dtStart) & " 00:00"
    strEnd = Year(dtEnd) & "/" & Month(dtEnd) & "/" & Day(dtEnd) & " 00:00"
    Debug.Print strStart
    Debug.Print strEnd
    
    Set colWLAppts = Session.Folders(strLiveId).Folders(strCalName).Items
    Set colAppts = Session.GetDefaultFolder(olFolderCalendar).Items
    
    colWLAppts.Sort "[Start]"
    colWLAppts.IncludeRecurrences = True
    
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True
    
    
    'Windows Liveにあってローカルにないアイテムをローカルに追加
    Debug.Print "-------- Add Items to local calendar"
    Set objWLAppt = colWLAppts.Find("[Start] < '" & strEnd & "' AND [End] >= '" & strStart & "'")
        
    While Not objWLAppt Is Nothing
        Debug.Print objWLAppt.Subject & "@" & objWLAppt.Location & "," & objWLAppt.Start & "-"; objWLAppt.End
        
        If Len(objWLAppt.Start) > 11 Then
            Set objAppt = colAppts.Find("[Start] = '" & Left(objWLAppt.Start, Len(objWLAppt.Start) - 2) & "' AND [Subject] = '" & objWLAppt.Subject & "'")
        Else
            Set objAppt = colAppts.Find("[Start] = '" & objWLAppt.Start & " 0:00' AND [Subject] = '" & objWLAppt.Subject & "'")
        End If
        f = False
        While (Not objAppt Is Nothing) And (f = False)
            If (objWLAppt.Subject = objAppt.Subject) And (objWLAppt.Location = objAppt.Location) And (objWLAppt.End = objAppt.End) Then
                f = True
            Else
                Set objAppt = colAppts.FindNext
            End If
        Wend
                
        If f = False Then
            Debug.Print " add "
            Set apptItem = colAppts.Add
            apptItem.Subject = objWLAppt.Subject
            apptItem.Location = objWLAppt.Location
            apptItem.Start = objWLAppt.Start
            apptItem.End = objWLAppt.End
            apptItem.Body = objWLAppt.Body
            apptItem.ReminderSet = objWLAppt.ReminderSet
            apptItem.Save
        Else
            Debug.Print " pass "
        End If
        
        Set objWLAppt = colWLAppts.FindNext
    Wend
    
    'ローカルにあってWindows Liveにないアイテムをローカルから削除
    Debug.Print "-------- Remove Items from local calendar"
    Set objAppt = colAppts.Find("[Start] < '" & strEnd & "' AND [End] >= '" & strStart & "'")
    
    While Not objAppt Is Nothing
    
        Debug.Print objAppt.Subject & "@" & objAppt.Location & "," & objAppt.Start & "-"; objAppt.End
        
        If Len(objAppt.Start) > 11 Then
            Set objWLAppt = colWLAppts.Find("[Start] = '" & Left(objAppt.Start, Len(objAppt.Start) - 2) & "' AND [Subject] = '" & objAppt.Subject & "'")
        Else
            Set objWLAppt = colWLAppts.Find("[Start] = '" & objAppt.Start & " 0:00' AND [Subject] = '" & objAppt.Subject & "'")
        End If
        
        f = False
        While (Not objWLAppt Is Nothing) And (f = False)
            If (objWLAppt.Subject = objAppt.Subject) And (objWLAppt.Location = objAppt.Location) And (objWLAppt.End = objAppt.End) Then
                f = True
            Else
                Set objWLAppt = colWLAppts.FindNext
            End If
        Wend
        
        If f = False Then
            Debug.Print " remove "
            objAppt.Delete
        Else
            Debug.Print " pass "
        End If
        
        Set objAppt = colAppts.FindNext
    Wend
    
    Debug.Print "Done."
    MsgBox "終了しました。"
End Sub

免責事項！！

このスクリプトで損害が発生してもいかなる責任も負えませんのでご了承ください。自己責任でお願いします。
Windows Liveカレンダーと同期しているOutlook Hotmail Connectorのカレンダーが空っぽの状態でこのスクリプトを走らせたら最後、Outlookのデフォルトのカレンダーも空っぽになりますよ。お気をつけください。
需要ないだろうなぁ。でもいいんだ、ネタになってるしな。