削除通知のメールをもとに予定を削除するマクロ


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


私の環境では、予定が削除されると削除された旨の通知メールも飛んでくるので
そのメールをトリガーに予定表の予定を削除したいと思っているのですが
マクロの知識も浅く苦戦しております。実装についてご助力いただけないでしょうか。

メールのルールですが
??????????????
【本文】
下記のスケジュールを削除しました。

日付:2014/10/28 14:00-2014/10/28 16:00
削除日:2014/10/27
予定:○○○○
場所:△△△
内容:◇◇◇
??????????????
メールの件名は登録メールと同じタイトルがセットされてしまっているので
本文の「下記のスケジュールを削除しました。」を条件に
日付と予定、場所の3つで予定表に登録されているデーターとマッチングし
合致した予定を削除するようにしたら良いかなと考えております。

予定表からデータを取得して比較するのがよく分からず
具体的な方法を教えていただけると幸いです。



受信したメッセージから文字列を切り出すには、Instr や Left、Mid といった文字列操作関数を使用します。
また、条件に一致する予定を検索するには Items コレクションの Find メソッドが使用可能ですが、件名や場所のような文字列を検索する際には ‘ などの特殊記号の扱いがちょっと面倒なので、開始日時と終了日時のみで検索を行い、検索されたアイテムから件名と場所が同じものを削除するというような処理にします。
まとめると、以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Object
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If objItem.MessageClass = "IPM.Note" And _
          objItem.Body Like "*下記のスケジュールを削除しました。*" Then
       DeleteMatchedAppointment objItem.Body
    End If
End Sub
'
Private Sub DeleteMatchedAppointment(ByVal strBody As String)
    Dim fldCal As Folder
    Dim strStart As String
    Dim strEnd As String
    Dim strSubject As String
    Dim strLocation As String
    Dim colItems As items
    Dim apptItem As AppointmentItem
    ' 日付:の次まで移動
    GetToken strBody, "日付:"
    ' 開始日時を取得
    strStart = GetToken(strBody, "-")
    ' 終了日時を取得
    strEnd = GetToken(strBody, vbCrLf)
    ' 予定:の次まで移動
    GetToken strBody, "予定:"
    ' 件名を取得
    strSubject = GetToken(strBody, vbCrLf)
    ' 場所:の次まで移動
    GetToken strBody, "場所:"
    ' 場所を取得
    strLocation = GetToken(strBody, vbCrLf)
    ' 既定の予定表を取得
    Set fldCal = Session.GetDefaultFolder(olFolderCalendar)
    '
    Set colItems = fldCal.items
    ' 開始日と終了日で検索
    Set apptItem = colItems.Find("[開始日]='" & strStart & "' and [終了日]='" & strEnd & "'")
    While Not apptItem Is Nothing
        ' 件名と場所が一致する場合だけ削除
        If apptItem.Subject = strSubject And apptItem.Location = strLocation Then
            apptItem.Delete
        End If
        Set apptItem = colItems.FindNext
    Wend
End Sub
' 指定されたキーワードまでの文字列を取得する
Private Function GetToken(ByRef strText As String, strDel As String)
    Dim i As Integer
    i = InStr(strText, strDel)
    GetToken = Left(strText, i - 1)
    strText = Mid(strText, i + Len(strDel))
End Function

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

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中