本文に記載された複数のイベントを Outlook の予定表に登録するマクロ


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


管理人様

マクロ素人にも関わらずマクロを組むことを会社に強制され困っておりこのサイトに辿り着きました。

何卒、ご助力頂きたく思います。

マクロで行いたい作業はメールで配信された複数のイベントの予定をoutlook のスケジュールに一括して登録するというものです。
例えば
2018年7月7日 イベント開始
2018年7月9日 イベントB開始
2018年7月20日 イベント開始

といった様な形で複数のイベントがメールに記載されているスケジュールの一括登録です。

イベントは毎月数多くあります。

お力添え頂ければ幸いです


ご要望の動作を実現するには、以下のような処理が必要となります。

  1. 本文を取得
  2. 1 行ずつ文字列を取得
  3. スペースの前の文字列を日付として取得
  4. スペースの後の文字列を予定の件名として取得
  5. 取得した日付と件名で予定アイテムを作成

本文は MailItem オブジェクトの Body プロパティにより取得します。
本文を 1 行ずつ処理するには改行コードまでの文字列を取り出すという処理を行いますが、改行位置を検索するには Instr 関数を使用し、文字列の分割は Left 関数と Mid 関数を使用します。
スペースの前後の文字列をそれぞれ取り出す場合も、Instr、Left、Mid 関数を使います。
文字列を日付に変換するには CDate 関数を使用します。
予定アイテムの作成は Application オブジェクトの CreateItem メソッドを使用し、取得した AppointmentItem の Subject、Start、End などを設定します。

まとめると以下のようなマクロになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddEventsFromSelectedItem()
     Dim objItem As MailItem
     ' 表示中のウィンドウからアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' イベント登録のサブを呼び出し
     AddEventsFromItem objItem
End Sub
' イベント登録のサブルーチン
Private Sub AddEventsFromItem(ByRef objItem As MailItem)
     On Error Resume Next
     Dim strBody As String
     Dim strLine As String
     Dim iLf As Integer
     Dim iSpc As Integer
     ' アイテムから本文を取得
     strBody = objItem.Body & vbLf
     strBody = Replace(strBody, vbCrLf, vbLf)
     ' 改行位置を検索
     iLf = InStr(strBody, vbLf)
     ' 改行がなくなるまで繰り返し
     While iLf > 0
         ' 改行位置までを行として取得
         strLine = Trim(Left(strBody, iLf - 1))
         ' 取得した行を本文から削除
         strBody = Mid(strBody, iLf + 1)
         ' スペース位置を検索
         iSpc = InStr(strLine, " ")
         ' スペースがあったら登録処理
         If iSpc > 0 Then
             Dim dtEvent As Date
             Err.Clear
             ' 最初のスペースまでを日付として取得
             dtEvent = CDate(Left(strLine, iSpc - 1))
             If Err.Number = 0 Then
                 ' 日付として正しければ登録
                 Dim apptItem As AppointmentItem
                 ' 予定アイテムを作成
                 Set apptItem = CreateItem(olAppointmentItem)
                 ' スペース以降を予定の件名に設定
                 apptItem.Subject = Mid(strLine, iSpc + 1)
                 ' 開始時刻はイベントの日付
                 apptItem.Start = dtEvent
                 ' 終了時刻は翌日の 0:00
                 apptItem.End = DateAdd("d", 1, dtEvent)
                 ' イベントは終日の予定
                 apptItem.AllDayEvent = True
                 ' 予定アイテムを保存
                 apptItem.Save
             End If
         End If
         ' 次の改行位置を検索
         iLf = InStr(strBody, vbLf)
     Wend
End Sub

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

コメントを残す

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中