LoginSignup
0
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@hirorin_

Outlookのカレンダーから自動で空き時間を探すマクロを作成

Posted at

概要

最近では、調整さんや様々なスケジュール調整ウェブアプリがあるのに、未だにメールで空き時間を聞かれて返答する機会が多いです。そこでOutlookのカレンダーか自動で空き時間を探すマクロを作りました。検索結果は以下のようなテキストボックスに表示されます。30分以上の空き時間と昼休みを抜いた時間帯が出てきます。

出力結果

image001.png

マクロの出力結果

Sub ListFreeTimesExcludingAllDayEvents()
    Const ThirtyMinutes As Double = 1 / 48 ' Represents 30 minutes in Excel time format
    Const LunchStartTime As Date = #12:00:00 PM#
    Const LunchEndTime As Date = #1:00:00 PM#
    
    Dim oCalendar As Folder
    Dim oItems As Items, oFilteredItems As Items
    Dim oAppt As AppointmentItem
    Dim CurrentDate As Date
    Dim StartTime As Date, EndTime As Date
    Dim CheckStartTime As Date, CheckEndTime As Date
    Dim FreeTimeStart As Date, FreeTimeEnd As Date
    Dim NextFreeTimeStart As Date
    Dim Filter As String
    Dim filePath As String
    Dim fileNo As Integer

    ' 検索する期間を設定
    StartTime = #6/3/2024#
    EndTime = #6/7/2024#

    ' 空き時間をチェックする時間帯を設定
    CheckStartTime = #9:00:00 AM#
    CheckEndTime = #8:00:00 PM#

    Set oCalendar = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Set oItems = oCalendar.Items

    oItems.Sort "[Start]"
    oItems.IncludeRecurrences = True

    ' 結果を保存するための一時ファイルを開く
    filePath = Environ("TEMP") & "\FreeTimes.txt"
    fileNo = FreeFile
    Open filePath For Output As fileNo

    ' 指定された日付範囲内の各日で空き時間をチェック
    CurrentDate = StartTime
    Do While CurrentDate <= EndTime
        FreeTimeStart = CurrentDate + TimeValue(CheckStartTime)
        FreeTimeEnd = CurrentDate + TimeValue(CheckEndTime)

        Filter = "[Start] <= '" & Format(FreeTimeEnd, "mm/dd/yyyy h:nn AMPM") & "' And [End] >= '" & Format(FreeTimeStart, "mm/dd/yyyy h:nn AMPM") & "'"
        Set oFilteredItems = oItems.Restrict(Filter)

        NextFreeTimeStart = FreeTimeStart

        For Each oAppt In oFilteredItems
            ' 終日の予定は無視
            If Not oAppt.AllDayEvent Then
                If oAppt.Start >= LunchStartTime And oAppt.End <= LunchEndTime Then
                    NextFreeTimeStart = oAppt.End
                Else
                    If oAppt.Start > NextFreeTimeStart Then
                        If DateDiff("n", NextFreeTimeStart, oAppt.Start) >= 30 Then
                            Print #fileNo, "空き時間: " & NextFreeTimeStart & " から " & oAppt.Start
                        End If
                    End If
                    NextFreeTimeStart = oAppt.End
                End If
            End If
        Next

        If NextFreeTimeStart < FreeTimeEnd And DateDiff("n", NextFreeTimeStart, FreeTimeEnd) >= 30 Then
            Print #fileNo, "空き時間: " & NextFreeTimeStart & " から " & FreeTimeEnd
        End If

        CurrentDate = DateAdd("d", 1, CurrentDate)
    Loop

    Close fileNo
    Shell "notepad.exe " & filePath, vbNormalFocus
End Sub

各コードの説明

1. 定数の設定

ThirtyMinutes: 30分を表すExcelの時間形式で、1日を48で割った値です。これは後で空き時間が30分以上かどうかをチェックするために使われます。

LunchStartTime と LunchEndTime: 昼休みの開始時間と終了時間を設定します。これにより、昼休みの時間帯の予定が考慮されます。

Const ThirtyMinutes As Double = 1 / 48 ' Represents 30 minutes in Excel time format
Const LunchStartTime As Date = #12:00:00 PM#
Const LunchEndTime As Date = #1:00:00 PM#

2. 変数の宣言

oCalendar: Outlook の予定表フォルダを表します。
oItems と oFilteredItems: 予定表のアイテム（イベントや予定）を格納するための変数です。
oAppt: 個々の予定を表す変数です。
CurrentDate: 現在の処理対象の日付を格納します。
StartTime と EndTime: チェックする期間の開始日と終了日を設定します。
CheckStartTime と CheckEndTime: 空き時間をチェックする時間帯（例: 午前9時から午後8時まで）を設定します。
FreeTimeStart, FreeTimeEnd, NextFreeTimeStart: 空き時間の開始と終了、次の空き時間の開始を追跡するための変数です。
Filter: 予定をフィルタリングするための条件を格納します。
filePath: 結果を保存する一時ファイルのパスです。
fileNo: ファイルの番号を管理します。

Dim oCalendar As Folder
Dim oItems As Items, oFilteredItems As Items
Dim oAppt As AppointmentItem
Dim CurrentDate As Date
Dim StartTime As Date, EndTime As Date
Dim CheckStartTime As Date, CheckEndTime As Date
Dim FreeTimeStart As Date, FreeTimeEnd As Date
Dim NextFreeTimeStart As Date
Dim Filter As String
Dim filePath As String
Dim fileNo As Integer

3. チェックする期間と時間帯の設定

StartTime と EndTime: 空き時間を調べる日付範囲を設定します。
CheckStartTime と CheckEndTime: 1日のうち空き時間をチェックする時間帯を設定します。

StartTime = #6/3/2024#
EndTime = #6/7/2024#
CheckStartTime = #9:00:00 AM#
CheckEndTime = #8:00:00 PM#

4. 予定表アイテムの取得と並べ替え

oCalendar にOutlookの既定の予定表フォルダを取得します。
oItems にそのフォルダ内の全ての予定を取得し、開始時間で並べ替えます。また、繰り返し予定も含めるように設定しています。

Set oCalendar = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items
oItems.Sort "[Start]"
oItems.IncludeRecurrences = True

5. 結果を保存するためのファイルを開く

一時ファイルを作成し、そのファイルに対して書き込みを行う準備をします。

filePath = Environ("TEMP") & "\FreeTimes.txt"
fileNo = FreeFile
Open filePath For Output As fileNo

6. 指定された日付範囲で空き時間をチェック

CurrentDate に基づいて、毎日 CheckStartTime から CheckEndTime の時間範囲で空き時間をチェックします。
Filter で現在の日時に該当する予定をフィルタリングし、 oFilteredItems に保存します。
NextFreeTimeStart に次の空き時間の開始時刻をセットします。

CurrentDate = StartTime
Do While CurrentDate <= EndTime
    FreeTimeStart = CurrentDate + TimeValue(CheckStartTime)
    FreeTimeEnd = CurrentDate + TimeValue(CheckEndTime)
    
    Filter = "[Start] <= '" & Format(FreeTimeEnd, "mm/dd/yyyy h:nn AMPM") & "' And [End] >= '" & Format(FreeTimeStart, "mm/dd/yyyy h:nn AMPM") & "'"
    Set oFilteredItems = oItems.Restrict(Filter)
    
    NextFreeTimeStart = FreeTimeStart

7. 空き時間の計算と記録

全日予定を無視し、昼休み中にある予定を処理します。
予定が NextFreeTimeStart よりも後に始まる場合、その間の空き時間が30分以上であるかをチェックし、30分以上であればその空き時間をファイルに記録します。
最後に NextFreeTimeStart をその予定の終了時刻に更新します。

For Each oAppt In oFilteredItems
    If Not oAppt.AllDayEvent Then
        If oAppt.Start >= LunchStartTime And oAppt.End <= LunchEndTime Then
            NextFreeTimeStart = oAppt.End
        Else
            If oAppt.Start > NextFreeTimeStart Then
                If DateDiff("n", NextFreeTimeStart, oAppt.Start) >= 30 Then
                    Print #fileNo, "空き時間: " & NextFreeTimeStart & " から " & oAppt.Start
                End If
            End If
            NextFreeTimeStart = oAppt.End
        End If
    End If
Next

8. 最後の空き時間の処理と次の日への移動

最後の予定の後で FreeTimeEnd までに残っている空き時間が30分以上であるかをチェックし、記録します。
CurrentDate を次の日に更新し、ループを継続します。

If NextFreeTimeStart < FreeTimeEnd And DateDiff("n", NextFreeTimeStart, FreeTimeEnd) >= 30 Then
    Print #fileNo, "空き時間: " & NextFreeTimeStart & " から " & FreeTimeEnd
End If

CurrentDate = DateAdd("d", 1, CurrentDate)
Loop

9. ファイルを閉じて結果を表示

ファイルを閉じた後、結果をメモ帳で開いて表示します。

Close fileNo
Shell "notepad.exe " & filePath, vbNormalFocus
0
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?