Outlook の予定表を iCalendar (ics) ファイルにエクスポートするマクロ


Outlook の予定表を CSV ファイルにエクスポートするマクロのコメントにて以下のご要望をいただきました。


いつもお世話になってます。
csvファイルではなく、icsファイルとして吐き出したいと考えているのですが、可能でしょうか?


AppointmentItem の SaveAs メソッドで 2 番目のパラメータに olICal を指定すると、iCalendar 形式のファイルとして保存が可能です。
ただし、1 アイテムにつき 1 ファイルとなります。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportThisMonthToICS()
    Const SAVE_PATH = "c:\export\" ' 保存するフォルダのパス。最後に必ず \ をつける
    Dim dtExport As Date
    Dim strStart As String
    Dim strEnd As String
    Dim objFSO 'As FileSystemObject
    Dim colAppts As Items
    Dim objAppt As AppointmentItem
    Dim i As Integer
    Dim arrErrChars
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    dtExport = Now ' 来月の予定をエクスポートする場合は Now の代わりに DateAdd("m",1,Now) を使用します。
    ' 月単位ではなく任意の単位にする場合は以下の記述を変更します。
    strStart = Year(Now) & "/" & Month(Now) & "/1 00:00"
    ' エクスポートする範囲の最後の日の次の日を strEnd に指定します。
    strEnd = DateAdd("m", 1, CDate(strStart)) & " 00:00"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set colAppts = Application.Session.GetDefaultFolder(olFolderCalendar).Items
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True
    Set objAppt = colAppts.Find("[Start] < """ & strEnd & """ AND [End] >= """ & strStart & """")
    While Not objAppt Is Nothing
        Debug.Print objAppt.Subject, objAppt.Start
        ' ファイル名を件名から作成
        strFileName = objAppt.Subject
        ' ファイル名として不適切な文字を _ に置き換える
        For i = 0 To UBound(arrErrChars)
            strFileName = Replace(strFileName, arrErrChars(i), "_")
        Next
        ' ファイル名が 260 文字を超えないようにする
        strFileName = Left(SAVE_PATH & strFileName, 250)
        ' 同名のファイルがある場合の処理
        If objFSO.FileExists(strFileName & ".ics") Then
            i = 2 ' (2) から始める
            While objFSO.FileExists(strFileName & "(" & i & ").ics")
                i = i + 1
            Wend
            strFileName = strFileName & "(" & i & ")"
        End If
        ' ファイルをフォルダに保存
        objAppt.SaveAs strFileName & ".ics", olICal
        Set objAppt = colAppts.FindNext
    Wend
End Sub

マクロの登録方法やメニューへの追加について

広告

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中