作り始めたら、止まらなくて、さっそく、リマインダ設定機能を追加してしまいました。
このあとは、サイボウズから自動的に取り込んで、設定するようにしたいけど、これは、少し、面倒そうなので、ここまでにしておこうと思います。(今でも、自動的にログインして、ファイルに保存するところまでは、できているので、これを、ひとつにまとめるということですが、ただ、いつダウンロードが終わったのかを調べるのが、面倒そう?)
このあとは、サイボウズから自動的に取り込んで、設定するようにしたいけど、これは、少し、面倒そうなので、ここまでにしておこうと思います。(今でも、自動的にログインして、ファイルに保存するところまでは、できているので、これを、ひとつにまとめるということですが、ただ、いつダウンロードが終わったのかを調べるのが、面倒そう?)
'#################################################
' サイボウズv3のスケジュールをOutlookにインポート
' copyright 2006 by 甘党のプログラマ
'#################################################
' 【機能】
' このVBAマクロは、サイボウズv3がCSV形式でエクスポートしたスケジュールを、Outlook2003の予定表に取り込みます。
' 取り込もうとしている日の予定は、タイトルに『《サイボウズ》』から始まっていると、削除します。
' サイボウズから取り込んだ予定のタイトルには、『《サイボウズ》』を付与し、
' さらに、内容の方にも、サイボウズから取り込まれた旨のコメントを追加します。
' [リマインダ設定機能]
' サイボウズのスケジュール登録時に、その件名の最後、『{{数字}}』を付けると、リマインダ(アラーム)を設定します。
' リマインダは分単位で、省略をすると、10分前に設定します。
' 使用例 :
' サイボウズのスケジュールに、『○○打合せ{{15}}』と設定すると、15分前に通知をします。
' サイボウズのスケジュールに、『△△打合せ{{}}』と設定すると、10分前に通知をします。
' 【注意】
' サイボウズから取り込んだ予定は、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 初版 : ファイル名固定とリマインダ設定機能未対応。
' v0.02 2007/1/2 リマインダ設定機能対応。ファイル名固定には未対応。
'
Sub ImportCybozuSchedule()
Dim strCybouzCSV As String ' OPENするサイボウズのCSVファイル名(フルパス)
Const olAppointmentItem = 1 ' objOutlook.CreateItemで予定を作成
Const strPrefixCybouz = "《サイボウズ》 " ' サイボウズからインポートした予定のタイトルに付与するプリフィックス
Const strPrefixCybouzForComp = strPrefixCybouz & "*" ' クリア時のマッチパターン(Like演算子用)
Const strSubjectForReminderChecking = "*{{*}}" ' リマインダチェック用のマッチパターン(Like演算子用)
Const intDefaultReminderTime = 10 ' リマインダのデフォルト(10分)
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
' リマインダの設定
If objAppointment.Subject Like strSubjectForReminderChecking Then
' 『{{』と『}}』の位置を探す
st = InStrRev(objAppointment.Subject, "{{")
en = InStrRev(objAppointment.Subject, "}}")
va = Val(Mid(objAppointment.Subject, st + 2, en - (st + 2)))
If va = 0 Then
' 『{{..}}』の値が変換できなかったから、デフォルト時間を設定
objAppointment.ReminderMinutesBeforeStart = intDefaultReminderTime
Else
'『{{..}}』の中身を設定
objAppointment.ReminderMinutesBeforeStart = va
End If
objAppointment.ReminderSet = True
Else
objAppointment.ReminderSet = False
End If
' 予定の追加
objAppointment.Save
numAddedItems = numAddedItems + 1
Loop
' 指定ファイルをCLOSE
Close #intCybouzCSV
'================
' 終了の表示
'================
MsgBox "インポートが完了しました。" & vbNewLine & "開始日 " & dateMinDate & vbNewLine & "終了日 " & dateMaxDate & vbNewLine & "削除数 " & numDeletedItems & vbNewLine & "追加数 " & numAddedItems, vbInformation, "ImportCybozuSchedule"
End Sub
}}
※コメント投稿者のブログIDはブログ作成者のみに通知されます