予定表を Excel ファイルにエクスポートし、Excel ファイルの変更をインポートするマクロ


コメントにて以下のご要望をいただきました。


いつもお世話になります。
  会社でクライアント側(windows7 &Outlook2013) & Exchangeサーバー環境で使用しています。
貴サイトの「複数フォルダーに格納されている特定の件名のメールの情報を Excel ファイルにエクスポートするマクロ」, 「メールの内容を Excel ファイルにかき出すマクロ」
などで紹介されているマクロをアレンジし、カレンダーアイテムやToDoアイテムの情報をExcelに一覧表形式にして出力さるマクロを試作しました(出力させる情報にCoversation ID, Entry IDが含まれます)。

Excelに書き出させるだけなので、情報を修正するときはOutlookに戻る必要があります。
せめて、Message ID, Coversation ID, Entry IDなど、ユニークに割り当てられるIDでアイテムを検索して表示させたいのですが、簡単な方法はあるでしょうか(該当するアイテムがメールフォルダ、スケジュール、ToDoにあるのかわからない前提で)。

【追伸】
もしくは、Excelに書き出された情報(日時、内容、完了のステータス等)を修正したらそれをOutlook側に反映させることができればもっと良いです

よろしくご教示ください


Outlook オブジェクト モデルの GetItemFromID メソッドを使用すると、一意のエントリー ID からアイテムを取得することができます。
このメソッドはアイテムがどのフォルダーにあるのかは意識せずに取得できますので、Excel にエクスポートする際にエントリー ID もエクスポートし、インポートの際にはそれを使って変更を取り込むという方法で実現は可能でしょう。

ただし、該当するアイテムがメール フォルダーにある場合と予定表にある場合とではインポートできるプロパティなどに違いが生じるため、インポートされるアイテムの種類ごとにマクロを用意する必要があると思います。

参考までに予定表をエクスポート・インポートするマクロを作ってみました。
なお、編集したものを再び取り込むという処理を考えた場合、繰り返しのアイテムは正しく処理することが難しいため、繰り返しアイテムはエクスポートしません。
また、予定アイテムについてはマクロでは本文のテキスト データしか取得ができないため、文字に色を付けていたり画像を埋め込んでいたような場合には、それらが失われます。

' ここをトリプルクリックでマクロ全体を選択できます。

' エクスポートする Excel ファイルの指定
Const EXCEL_FILE = "c:\temp\calendar.xlsx"
'
' エクスポートするマクロ
'
Public Sub ExportCalendarWithEID()
     Dim appExcel 'As Excel.Application
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim fldCalendar As Folder
     Dim apptItem As AppointmentItem
     Dim iRow As Integer
     ' Excel を起動
     Set appExcel = CreateObject("Excel.Application")
     ' ワークブックを追加
     Set objBook = appExcel.Workbooks.Add()
     ' ワークブックのワークシート 1 を取得
     Set objSheet = objBook.Sheets(1)
     ' 先頭行に項目名を追加
     With objSheet
         .Cells(1, 1) = "EntryID"
         .Cells(1, 2) = "件名"
         .Cells(1, 3) = "場所"
         .Cells(1, 4) = "開始日時"
         .Cells(1, 5) = "終了日時"
         .Cells(1, 6) = "分類項目"
         .Cells(1, 7) = "本文"
     End With
     ' データは 2 行目から
     iRow = 2
     ' 予定表フォルダーを取得
     Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
     ' 予定表フォルダーのすべてのアイテムについて取得
     For Each apptItem In fldCalendar.Items
         ' 繰り返しの予定は除外する
         If Not apptItem.IsRecurring Then
             ' ワークシートに予定アイテムのプロパティをコピー
             With objSheet
                 .Cells(iRow, 1) = apptItem.EntryID
                 .Cells(iRow, 2) = apptItem.Subject
                 .Cells(iRow, 3) = apptItem.Location
                 .Cells(iRow, 4) = apptItem.Start
                 .Cells(iRow, 5) = apptItem.End
                 .Cells(iRow, 6) = apptItem.Categories
                 .Cells(iRow, 7) = apptItem.Body
             End With
             ' 次の行に移動
             iRow = iRow + 1
         End If
     Next
     ' ファイル名を付けて保存
     objBook.SaveAs EXCEL_FILE
     objBook.Close
     appExcel.Quit
End Sub
'
' インポートするマクロ
'
Public Sub ImportCalendarWithEID()
     On Error Resume Next
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim iRow As Integer
     Dim strEID As String
     Dim apptItem As AppointmentItem
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     ' ワークシート 1 を取得
     Set objSheet = objBook.Sheets(1)
     ' データは 2 行目から
     iRow = 2
     '
     With objSheet
         ' 1 列目が空白でない限り繰り返し
         While .Cells(iRow, 1) <> ""
             ' 1 列目をエントリー ID として取得
             strEID = .Cells(iRow, 1)
             ' エントリー ID でアイテムを取得
             Set apptItem = Session.GetItemFromID(strEID)
             ' エラーが発生していなければセルの値をプロパティにコピー
             If Err.Number = 0 Then
                 apptItem.Subject = .Cells(iRow, 2)
                 apptItem.Location = .Cells(iRow, 3)
                 ' 変更後の開始が変更前の終了より後なら終了を先に設定
                 If apptItem.End < .Cells(iRow, 4) Then
                     apptItem.End = .Cells(iRow, 5)
                     apptItem.Start = .Cells(iRow, 4)
                 Else
                     apptItem.Start = .Cells(iRow, 4)
                     apptItem.End = .Cells(iRow, 5)
                 End If
                 apptItem.Categories = .Cells(iRow, 6)
                 apptItem.Body = .Cells(iRow, 7)
                 apptItem.Save
             Else
                 Err.Clear
             End If
             ' 次の行に移動
             iRow = iRow + 1
         Wend
     End With
     objBook.Application.Quit
End Sub

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Google+ フォト

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

Twitter 画像

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

Facebook の写真

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

w

%s と連携中