Outlookの予定表を登録するExcelVBAコード2(終日対応)

スポンサーリンク

Outlookの予定表を削除する手順は難しい

以前にこちらでOutlookの予定表を登録するExcelVBAコードを紹介したことがあります。

この時は終日のイベントを考慮していなかったこと、日付の設定の仕方があまり適切でなかったことがあり、今回修正案を作成することにしました。

今回使用するワークシートについて

今回作成するExcelVBAを使用するにあたって使用するシートは下記の通りです。
以前紹介した表の右端H列に「終日」の項目を用意しています。

127-2

スポンサーリンク

以前の予定表作成から修正点2か所

①終日イベントの設定

Outlookの予定表アイテムを「aItem」とした場合、「aITEM.AllDayEvent = True」とすると終日のイベントとして登録することができます。

私の環境(Windows10+Office2016)だけのバグかもしれませんが、終日設定をする際に時間は事前に「0:00:00」としておかないとうまく登録されないようです。

②開始日時・終了日時の設定

開始日時・終了日時を以前は文字列形式で設定しましたが、色々と不具合が生じる可能性があったので、日付型を用いるようにしました。

Outlookの予定表アイテムを「aItem」とした場合、開始日時・終了日時は下記のように設定しています。

  • aITEM.Start = 開始日 + 開始時間
  • aITEM.End = 終了日 + 終了時間
  • ③分類項目の設定

    同僚から予定表登録時に色分けをしたいと要望があったため分類項目を設定できるようにしました。
    分類項目はアカウントごとに名称を自由に設定できてしまうため、項目名をセルに入力する仕様としています。

    省略可能にしておいて、空欄のままだと分類項目を設定しないように設定しています。

    Outlookの予定表を自動入力するExcelVBAコードについて

    今回作成したExcelVBAコードは下記の通りです。
    終日の処理だったり、終了日時未記載の場合の条件分岐が入っているのでコードは長いですが、簡単な繰り返しで作成できていると思います。

    内容作成の時の「自動入力」の文字は削除する際のフラグとして入力しています。
    (詳細はこちらの記事参照)

    Sub シートからアウトルック予定表入力()

    Dim i As Long
    Dim oApp ’As Outlook.Application OutlookのApplication オブジェクトを入れる
    Dim myNameSpace ’As Outlook.NameSpace
    Dim myFolder ’As Outlook.Folder フォルダー指定

    Set oApp = CreateObject(“Outlook.Application”)
    Set myNameSpace = oApp.GetNamespace(“MAPI”)
    Set myFolder = myNameSpace.GetDefaultFolder(9) ’規定のフォルダー olFolderCalendar=9 指定

    myFolder.Display
    oApp.ActiveWindow.WindowState = 2 ’olNormalWindow=2 (olMaximized=0,olMinimized=1)

    Dim aITEM ’As Outlook.AppointmentItem

    Dim タイトル As String, 場所 As String, 内容 As String
    Dim 開始日 As Date, 開始時間 As Date, 終了日 As Date, 終了時間 As Date
    Dim 終日 As Boolean
    Dim 分類項目 As String

    i = 2
    Do Until Cells(i, 1).Value = “”

    タイトル = Cells(i, 1)
    場所 = Cells(i, 2)
    内容 = “自動入力” & VbCrLf & Cells(i, 3)’「自動入力」は削除したい時のフラグ
    開始日 = Cells(i, 4)

    ’分類項目
    If Cells(i, 9) <> “” Then
    分類項目 = Cells(i, 9)
    Else
    分類項目 = “”
    End If

    If Cells(i, 8) <> “” Then ’終日のイベントかどうか判定
    終日 = True
    開始時間 = “0:00:00”
    終了日 = 開始日 + 1 ’終日イベントの終了日は開始日の翌日に設定
    終了時間 = “0:00:00”

    Else ’終日のイベントではない場合
    終日 = False
    ’開始時刻記載有無の条件分岐
    If Cells(i, 5) = “” Then
    開始時間 = “0:00:00”
    Else
    開始時間 = Cells(i, 5)
    End If

    ’終了日記載有無の条件分岐
    If Cells(i, 6).Text = “” Then
    終了日 = 開始日
    Else
    終了日 = Cells(i, 6)
    End If

    ’終了時間記載有無の条件分岐
    If Cells(i, 7).Text = “” Then
    終了時間 = “0:00:00”
    Else
    終了時間 = Cells(i, 7)
    End If

    End If

    Set aITEM = oApp.CreateItem(1) ’olAppointmentItem=1 1予定・アポを指定
    aITEM.Display ’編集画面表示

    aITEM.Subject = タイトル
    aITEM.Body = 内容
    aITEM.Location = 場所

    aITEM.Start = 開始日 + 開始時間
    aITEM.End = 終了日 + 終了時間

    If 終日 = False Then
    aITEM.AllDayEvent = False
    Else
    aITEM.AllDayEvent = True
    End If

    If 分類項目 <> “” Then
    aITEM.Categories = 分類項目
    End If

    aITEM.Save
    aITEM.Close 0
    Set aITEM = Nothing

    i = i + 1
    Loop

    Set myFolder = Nothing
    Set myNameSpace = Nothing
    Set oApp = Nothing
    ’oApp.Quit ’登録後Outlookを終了する場合はチェックを外す

    End Sub

    コメント

    1. むら より:

      お世話になります。
      こちらを活用してみたいのですが、自分以外の人のスケジュールにも登録をすることは可能でしょうか。

      • okumasahito より:

        コメントありがとうございます。
        相手の予定表にそのまま登録することはできませんが
        会議出席依頼という形で送ることは可能だと思います。
        手順は下記です。
        ①J列に相手先のメールアドレスを追加する
        ②aItemに予定表アイテムを格納した後の行で下記を追加します。

        ’予定を会議に変更
        If Cells(i, 10) <> “” Then
        aITEM.MeetingStatus = 1 ‘ olMeeting
        aITEM.Recipients.Add Cells(i, 10)
        End If

        ③保存して閉じるを送信するに変更

        aITEM.Save
        aITEM.Close 0

        aITEM.Send

        に変更することで相手に会議出席依頼が届くようになると思います。

    2. vba難しい より:

      ご説明ありがとうございました。
      大変参考になります。
      規定の予定表ではなく、自分で作成したサブの予定表に登録するにはどうしたら良いでしょうか。
      規定の予定表を変えれば登録できるのですが、変えたくないので。
      もし方法があれば教えていただけると非常に助かります。
      よろしくお願い致します。

      • okumasahito より:

        ご連絡ありがとうございます。
        すみません。
        既定以外の予定表への登録方法は私にはわかりません。
        ネット上の情報も規定の予定表に対する処理ばかりでよい方法が見つかりませんでした。
        できたとしてもコードはかなり難しくなりそうですね。