サイボウズv3のスケジュールをOutlookにインポート

今日から、お休みで、うれしいのです、、、。

で、前々から作りたかったサイボウズv3のスケジュールをOutlookに
インポートするOutlookのVBAのマクロを作っていました。
それにしても、OutlookのVBAのマクロは、情報が少ないですね。
書籍も、和書は、ないようですし、操作のレコーディングができないので、
作りづらいし、そもそも、VBA自体が見よう見真似なので、一行一行、
ためしためしで、かなり、面倒でした。

で、まだ、公開できるような状態ではないような気がしますが、
自分自身のバージョン管理もかねて、このブログにVBAのソース自体を
貼り付けておこうと思います。

なお、本当は、strCybouzCSVに設定するCSVファイルのパスは、
固定ではなくて、ファイルダイアログで指定させた方が良いような気もしますが、
とりあえず、現状は、サイボウズから自動的にダウンロードするマクロに
合わせて、固定ファイルパス名としてしまっています。
あまりに、ニッチなマクロなので、これを使う人がいるとは到底思えませんが、
とりあえず、使う方がいるようであれば、以下の★の部分を含めて、各自で、
調整をする必要があります。

strCybouzCSV = "C:★★★★★★★schedule.csv"


以下が、さっき、作ったマクロ

'#################################################
' サイボウズv3のスケジュールをOutlookにインポート
' copyright 2006 by 甘党のプログラマ
'#################################################
' 【機能】
' このVBAマクロは、サイボウズv3がCSV形式でエクスポートしたスケジュールを、Outlook2003の予定表に取り込みます。
' 取り込もうとしている日の予定は、タイトルに「《サイボウズ》」から始まっていると、削除します。
' サイボウズから取り込んだ予定のタイトルには、「《サイボウズ》」を付与し、
' さらに、内容の方にも、サイボウズから取り込まれた旨のコメントを追加します。
' 【注意】
' サイボウズから取り込んだ予定は、Outlookで編集してしまうと削除されるので、サイボウズ側で編集するようにしてください。
' 【参考】
' http://www.microsoft.com/japan/technet/scriptcenter/resources/officetips/apr05/tips0405.mspx
'     Microsoft TechNet ; Microsoft Outlook の予定を作成する
' http://yutaro.air-nifty.com/hitorigoto/2006/05/notesoutlook_1047.html
'     ポン太さんのブログ「ポン太独り言」2006.05.16 「Notesの予定をOutlookへ」
' 【備考】
' サイボウズv3がエクスポートするスケジュールのフィールドの仕様
'1,     2,       3,     4,       5,6,   7,8,   9,10
' ,開始日,開始時刻,終了日,終了時刻, ,件名, ,場所,内容
'
' 【履歴】
' v0.01 2006/12/28 初版 : ファイル名固定、リマインダ未対応
'
Sub ImportCybozuSchedule()
    Dim strCybouzCSV As String                  ' OPENするサイボウズのCSVファイル名(フルパス)
    Const olAppointmentItem = 1                 ' objOutlook.CreateItemで予定を作成
    Const strPrefixCybouz = "《サイボウズ》 "      ' サイボウズからインポートした予定のタイトルに付与するプリフィックス
    Const strPrefixCybouzForComp = strPrefixCybouz & "*"    ' クリア時のマッチパターン(Like演算子用)

    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim strDummy1 As String         '1
    Dim strAppoStartDay As String   '2
    Dim strAppoStartTime As String  '3
    Dim strAppoEndDay As String     '4
    Dim strAppoEndTime As String    '5
    Dim strDummy6 As String         '6
    Dim strAppoSubject As String    '7
    Dim strDummy8 As String         '8
    Dim strAppoPlace As String      '9
    Dim strAppoContents As String   '10

    Dim dateMinDate As Date     ' インポートする期間の開始日
    Dim dateMaxDate As Date     ' インポートする期間の終了日

    Dim numDeletedItems As Integer       ' 削除したアイテムの個数
    Dim numAddedItems As Integer         ' 追加したアイテムの個数

    numDeletedItems = 0
    numAddedItems = 0


    '================
    ' ロードするCSVファイル
    '================
    ' とりあえず、ロードするCSVファイルは、デスクトップのschedule.csvにしている。
    ' 本当は、ファイルダイアログで指定させたいか? [TODO]
    strCybouzCSV = "C:★★★★★★★schedule.csv"

    ' 使用可能なファイル番号を取得
    intCybouzCSV = FreeFile


    '================
    ' インポートする期間を取得して、Outlookの予定をクリアする
    '================
    ' ---------------
    ' まずは、ロードするCSVファイルをスキャンして、インポートする期間の開始日と終了日をチェックする
    ' ---------------
    ' 指定ファイルをOPEN(入力モード)
    Open strCybouzCSV For Input As #intCybouzCSV
    ' ファイルのEOF(End of File)まで繰り返す

    Set objOutlook = CreateObject("Outlook.Application")

    dateMinDate = #1/1/2999#    ' とりあえず、ありえない未来を設定
    dateMaxDate = #1/1/1900#    ' とりあえず、ありえない過去を設定
    Do Until EOF(intCybouzCSV)
        ' レコードを読み込む
        Input #intCybouzCSV, strDummy1, strAppoStartDay, strAppoStartTime, strAppoEndDay, strAppoEndTime, strDummy6, strAppoSubject, strDummy8, strAppoPlace, strAppoContents

        If dateMinDate > strAppoStartDay Then
            dateMinDate = strAppoStartDay & " 00:00:00"
        End If
        If strAppoEndDay <> "" Then
            If dateMaxDate <strAppoEndDay Then= dateMinDate) And (myItem.Start <= dateMaxDate) Then

            ' インポートする期間の予定であれば、タイトルをチェックする。
            If myItem.Subject Like strPrefixCybouzForComp Then
                ' アイテムの削除
                myItem.Delete
                numDeletedItems = numDeletedItems + 1
            End If
        End If
    Next i


    '================
    ' 実際のレコードのインポート開始
    '================
    ' 指定ファイルをOPEN(入力モード)
    Open strCybouzCSV For Input As #intCybouzCSV
    ' ファイルのEOF(End of File)まで繰り返す

    Set objOutlook = CreateObject("Outlook.Application")

    Do Until EOF(intCybouzCSV)
        ' レコードを読み込む
        Input #intCybouzCSV, strDummy1, strAppoStartDay, strAppoStartTime, strAppoEndDay, strAppoEndTime, strDummy6, strAppoSubject, strDummy8, strAppoPlace, strAppoContents

        Set objAppointment = objOutlook.CreateItem(olAppointmentItem)
        
        If strAppoStartTime <> "" Then
            objAppointment.Start = strAppoStartDay & " " & strAppoStartTime
        
            If strAppoEndDay <> "" Then
                If strAppoEndTime <> "24:00:00" Then
                    ' 開始と終了から予定の時間(分)を設定
                    objAppointment.Duration = DateDiff("n", objAppointment.Start, strAppoEndDay + " " + strAppoEndTime)
                Else
                    ' Outlookは、"24:00:00"なんて時間を扱えないので、"23:59:59"にする。
                    objAppointment.Duration = DateDiff("n", objAppointment.Start, strAppoEndDay + " " + "23:59:59")
                End If
            Else
                ' サイボウズでは、終了を指定しなくとも登録できしまう。
                objAppointment.Duration = 0
            End If
        Else
            objAppointment.Start = strAppoStartDay
            objAppointment.AllDayEvent = True    ' 終日に設定
        End If
        
        objAppointment.Subject = strPrefixCybouz & strAppoSubject
        objAppointment.Body = strAppoContents & vbNewLine & "---------" & vbNewLine & "《サイボウズからインポートされた予定です。次のImportCybozuScheduleマクロ実行でインポート日と重複していたら、削除されるので、更新しないでください。》"
        objAppointment.Location = strAppoPlace

        ' [TODO] リマインダの設定機能を入れたいですね。
        'objAppointment.ReminderMinutesBeforeStart = 15
        objAppointment.ReminderSet = False

        ' 予定の追加
        objAppointment.Save
        numAddedItems = numAddedItems + 1

    Loop
    ' 指定ファイルをCLOSE
    Close #intCybouzCSV


    '================
    ' 終了の表示
    '================
    MsgBox "インポートが完了しました。" & vbNewLine & "開始日 " & dateMinDate & vbNewLine & "終了日 " & dateMaxDate & vbNewLine & "削除数 " & numDeletedItems & vbNewLine & "追加数 " & numAddedItems, vbInformation, "ImportCybozuSchedule"

End Sub

-----

このマクロを作ったきっかけは、以下のブログを見つけたからでした。

http://yutaro.air-nifty.com/hitorigoto/2006/05/notesoutlook_1047.html
ポン太さんのブログ「ポン太独り言」2006.05.16 「Notesの予定をOutlookへ」

で、初めて、トラックバックをしてみました。