受信したメールをもとに予定表アイテムを作成するマクロ


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


会社のスケジュール管理システムから送信されるメールを元に、Outlookの予定表アイテムを
作成するマクロを作りたいと考えておりますが、力不足にてご助力をお願いできますでしょうか。

似たようなマクロを過去に公開して頂いておりますが、メール本文に記載されている日時情報などを
予定表アイテムに反映したい要望がございます。

スケジュール管理システムからのメールは、以下のルールで送信されます。

<メールのルール>
=======================

件名:
スケジュール登録のお知らせ「(スケジュール名称)」

本文:

登録者 : (登録者氏名)

————————————————–
下記のスケジュールが登録されました。
————————————————–
件名 : (スケジュール名称)
分類 :
日時 : 2012/07/30 19:30 – 20:00 (←日付表示の例)
設備 :
場所 : (場所)
備考 :

=======================

仕分けルールを作成し、件名が合致した場合にマクロを実行
予定表アイテムに以下のルールで作成したい。

<作りたい予定表アイテム>
=======================
件名 (上の例ではスケジュール名称)
場所 (上の例では場所)
開始時刻 (上の例では 2012/07/30 19:30)
終了時刻 (上の例では 2012/07/30 20:00)
本文 (メールの本文全部コピー)
=======================

具体的な方法を教えて頂けますと幸いです。
よろしくお願いします。


以下のようなマクロで実現が可能でしょう。

' ここをトリプルクリックでマクロ全体を選択できます。
' アイテムを受信するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    ' メッセージアイテムのみ処理
    If objItem.MessageClass = "IPM.Note" Then
        SaveAppointmentFromMessage objItem
    End If
End Sub
' メッセージから予定を作成する
Private Sub SaveAppointmentFromMessage(ByVal objMail As MailItem)
    Dim strBody As String
    Dim strSubject As String
    Dim strLocation As String
    Dim strDate As String
    Dim strStart As String
    Dim strEnd As String
    Dim i As Long
    Dim objAppt As AppointmentItem
    ' スケジュール管理ソフト以外からのメールは処理しない
    If Not objMail.Subject Like "スケジュール登録のお知らせ*" Then
        Exit Sub
    End If
    ' 本文を取得
    strBody = objMail.Body
    ' 本文から件名や場所などを取得
    strSubject = GetField(strBody, "件名 : ")
    strLocation = GetField(strBody, "場所 : ")
    strDate = GetField(strBody, "日時 : ")
    If strDate <> "" Then
        ' 開始時刻を取得
        i = 1
        While InStr("0123456789/: ", Mid(strDate, i, 1)) > 0
            i = i + 1
        Wend
        strStart = Left(strDate, i - 1)
        While InStr("0123456789/: ", Mid(strDate, i, 1)) = 0
            i = i + 1
        Wend
        ' 終了時刻を取得
        strEnd = Left(strStart, 11) & Mid(strDate, i)
        i = 1
        While InStr("0123456789/: ", Mid(strDate, i, 1)) > 0
            i = i + 1
        Wend
        strEnd = Left(strDate, i - 1)
    Else
        Exit Sub
    End If
    ' 取得した情報で予定アイテムを作成
    Set objAppt = Application.CreateItem(olAppointmentItem)
    objAppt.Subject = strSubject
    objAppt.Location = strLocation
    objAppt.Start = strStart
    objAppt.End = strEnd
    objAppt.Body = strBody
    objAppt.Save
End Sub
' 本文から特定の情報を取得する関数
Private Function GetField(strBody As String, strName As String)
    Dim i As Long
    Dim strValue As String
    i = InStr(strBody, strName)
    If i > 0 Then
        strValue = Mid(strBody, i + Len(strName))
        strValue = Left(strValue, InStr(strValue, vbCrLf) - 1)
        GetField = Trim(strValue)
    Else
        GetField = ""
    End If
End Function

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

広告

受信したメールをもとに予定表アイテムを作成するマクロ」への10件のフィードバック

  1. 私もスケジュール管理システムの通知メールから、Outlookの予定に自動登録したくネットをさまよって、こちらのページにたどり着きました。掲載されているコードに試行錯誤しつつ手を入れて、私が使っているスケジュール管理システム用に調整して動作させることができました。コード公開に感謝します。

    こちらのコードはメールを受信時に問答無用で予定として自動登録しますが、例えばスケジュール通知のメールを表示した状態でリボンに登録したマクロ起動ボタンから実行する、あるいは仕分けルールから起動する、という使い方にコードを修正することは可能でしょうか。

    このページに掲載しているコードが、私にとってのOutlook VBA初コンタクトだったので、おそらくかなり基礎的な部分の質問かもしれませんが、教えていただけると助かります。

    • 表示しているメールでこの処理を行うには、以下のようなマクロを追加し、このマクロをリボンに登録します。

      Public Sub SaveAppointmentFromActiveMessage()
      SaveAppointmentFromMessage ActiveExplorer.CurrentItem
      End Sub

      また、ルールのスクリプトとして実行する場合は、

      Private Sub SaveAppointmentFromMessage(ByVal objMail As MailItem)

      Sub SaveAppointmentFromMessage(ByRef objMail As MailItem)

      としてください。
      これにより、ルールの実行アクションの「スクリプト」として SaveAppointmentFromMessage が表示されるようになるでしょう。

    • リボンに登録する方を試したのですが、「SaveAppointmentFromMessage ActiveExplorer.CurrentItem」の行で「オブジェクトは、このプロパティまたはメソッドをサポートしていません。」とエラーになります。

      よくわからずにエラーが発生する行を「SaveAppointmentFromMessage ActiveInspector.CurrentItem」にしたら、メール詳細画面での実行では動作するようになりました。

      ただ、メール一覧画面でメールを選択した状態で実行すると、前者も後者もエラーとなります。どのようにすればメール一覧画面にも対応できるでしょうか。

      • すみません。
        記述がちょっと違いました。

        以下のようにしてみてください。
        Public Sub SaveAppointmentFromActiveMessage()
        If TypeName(ActiveWindow) = “Explorer” Then
        SaveAppointmentFromMessage ActiveExplorer.Selection(1)
        Else
        SaveAppointmentFromMessage ActiveInspector.CurrentItem
        End If
        End Sub

      • ありがとうございます! うまく行きました。
        このような考え方(Outlook VBAの基礎のキソ)というのはどこで学べばよいのでしょうか。いいサイトや書籍がありましたらご紹介いただけると助かります。

      • Outlook のヘルプをご覧になったことはありますか?
        Outlook で Visual Basic を起動し、F1 を押すと開発者用のヘルプが表示されます。
        このブログのマクロの大半はヘルプに記載されている内容だけで作成できると思います。

  2. こんにちは。
    いつも御世話になっております。

    受信メールからの予定表登録ですが、日付の後の時間指定が
    1.開始時間、終了時間ともにあり
    2.開始時間、終了時間ともになし
    3.開始時間なし、終了時間のみあり

    の三パターンのメールに対応させるためには、どのようにしたら良いのでしょうか。

    3の開始時刻なしは、日付は入力されているので、メールの受信日時を開始時間にしたいとおもっています。

    行き詰まってしまって、まったくさきにすすめなくなりました。
    よろしくおねがいします。

  3. こんにちは。本マクロを参考に私の環境に合わせた修正をすることで
    メールを元に予定表を登録することが出来るようになりました。

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

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

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

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

    よろしくお願いいたします。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中