VBAでOutlook予定表を管理！初心者でもスケジュールを確認する方法

Dim outlookApp As Outlook.Application
'// Outlookアプリケーションを操作するための変数を宣言しています。
'// (変数名は、outlookAppでなくても問題ありません)

Set outlookApp = New Outlook.Application
'// 実際にOutlookアプリケーションを起動し、操作できるようにしています。

Dim outlookApp As Object
'// Outlookアプリケーションを操作するための変数を宣言しています。
'// (変数名は、outlookAppでなくても問題ありません)

Set outlookApp = CreateObject("Outlook.Application")
'// 実際にOutlookアプリケーションを起動し、操作できるようにしています。

Dim outlookApp As Outlook.Application
Dim ns As Outlook.Namespace

'// Outlookアプリケーションを取得
Set outlookApp = CreateObject("Outlook.Application")

'// Namespaceを取得
Set ns = outlookApp.GetNamespace("MAPI")

Dim recipient As Outlook.Recipient
Dim sharedCalendar As Outlook.MAPIFolder
Dim email As String

'// 他人のメールアドレスを指定
email = "someone@example.com"

'// 他人の予定表を取得
Set recipient = ns.CreateRecipient(email)
recipient.Resolve ' アドレスが正しいか確認

If recipient.Resolved Then
    Set sharedCalendar = ns.GetSharedDefaultFolder(recipient, olFolderCalendar)
    MsgBox "共有予定表のフォルダ名: " & sharedCalendar.Name
Else
    MsgBox "指定されたメールアドレスのユーザーが見つかりません。"
End If

Dim calendarFolder As Outlook.MAPIFolder

'// Namespaceから予定表フォルダを取得
Set calendarFolder = ns.GetDefaultFolder(olFolderCalendar) '// 予定表

Dim subFolder As Outlook.MAPIFolder

'// サブフォルダを取得
Set subFolder = calendarFolder.Folders("プロジェクトA")
MsgBox "サブフォルダ名: " & subFolder.Name

Dim items As Outlook.Items

'// 予定表フォルダ内のアイテムを取得
Set items = calendarFolder.Items

Dim item As Object

'// すべてのアイテムを列挙
For Each item In items
    Debug.Print item.Subject '// 件名をデバッグウィンドウに出力
Next item

Dim filteredItems As Outlook.Items

'// 特定期間の予定を抽出
Set filteredItems = items.Restrict("[Start] >= '2024/01/01' AND [Start] <= '2024/12/31'")

Dim appt As Object
Dim filteredItems As Outlook.Items

'// 特定期間内の予定を取得
Set filteredItems = items.Restrict("[Start] >= '2024/01/01' AND [Start] <= '2024/12/31'")

'// 取得した予定を列挙
For Each appt In filteredItems
    If TypeOf appt Is Outlook.AppointmentItem Then
        Debug.Print appt.Subject & " - " & appt.Start
    End If
Next appt

Dim appt As Outlook.AppointmentItem

'// フォルダ内の最初の予定を取得
Set appt = items(1)

'// 予定の詳細を表示
Debug.Print appt.Subject       '// 件名
Debug.Print appt.Start         '// 開始日時
Debug.Print appt.End           '// 終了日時
Debug.Print appt.Location      '// 場所
Debug.Print appt.Body          '// 詳細（本文）

On Error Resume Next
Set outlookApp = GetObject(, "Outlook.Application")

If outlookApp Is Nothing Then
    Set outlookApp = CreateObject("Outlook.Application")
End If

On Error GoTo 0

Dim startDate As String
Dim endDate As String

startDate = Format(Date, "yyyy/mm/dd")
endDate = Format(Date + 7, "yyyy/mm/dd")

Dim ws As Worksheet
On Error Resume Next

Set ws = ThisWorkbook.Sheets("予定表データ")
If ws Is Nothing Then
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "予定表データ"
End If

On Error GoTo 0

Public Sub ExportOutlookAppointments()
    Dim outlookApp As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim calendarFolder As Outlook.MAPIFolder
    Dim items As Outlook.Items
    Dim filteredItems As Outlook.Items
    Dim appt As Object
    Dim ws As Worksheet
    Dim startDate As String
    Dim endDate As String
    Dim i As Long

    '// 日付範囲を指定
    startDate = Format(Date, "yyyy/mm/dd")      '// 現在の日付
    endDate = Format(Date + 7, "yyyy/mm/dd")    '// 現在から7日後

    '// Outlookアプリケーションのセットアップ
    Set outlookApp = CreateObject("Outlook.Application")
    Set ns = outlookApp.GetNamespace("MAPI")
    Set calendarFolder = ns.GetDefaultFolder(olFolderCalendar)

    '// アイテムを取得し、フィルタリング
    Set items = calendarFolder.Items
    items.Sort "[Start]"
    items.IncludeRecurrences = True
    Set filteredItems = items.Restrict("[Start] >= '" & startDate & "' AND [Start] <= '" & endDate & "'")

    '// Excelシートを準備
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Cells(1, 1).Value = "件名"
    ws.Cells(1, 2).Value = "開始日時"
    ws.Cells(1, 3).Value = "終了日時"
    ws.Cells(1, 4).Value = "場所"
    ws.Cells(1, 5).Value = "詳細"

    '// フィルタリング結果をExcelに出力
    i = 2
    For Each appt In filteredItems
        If TypeOf appt Is Outlook.AppointmentItem Then
            ws.Cells(i, 1).Value = appt.Subject
            ws.Cells(i, 2).Value = appt.Start
            ws.Cells(i, 3).Value = appt.End
            ws.Cells(i, 4).Value = appt.Location
            ws.Cells(i, 5).Value = appt.Body
            i = i + 1
        End If
    Next appt

    MsgBox "予定表のデータをExcelに出力しました。", vbInformation

    '// オブジェクトの解放
    Set appt = Nothing
    Set filteredItems = Nothing
    Set items = Nothing
    Set calendarFolder = Nothing
    Set ns = Nothing
    Set outlookApp = Nothing
End Sub

Public Sub ExportFilteredAppointmentsByKeyword()
    On Error GoTo ErrorHandler

    Dim outlookApp As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim calendarFolder As Outlook.MAPIFolder
    Dim items As Outlook.Items
    Dim filteredItems As Outlook.Items
    Dim appt As Object
    Dim ws As Worksheet
    Dim i As Long
    Dim keyword As String
    Dim startDate As String
    Dim endDate As String

    '// キーワードを指定
    keyword = InputBox("取得する予定のキーワードを入力してください:", "キーワード指定", "会議")
    If keyword = "" Then
        MsgBox "キーワードが指定されていません。処理を中止します。", vbExclamation
        Exit Sub
    End If

    '// 日付範囲を指定（現在から1か月後）
    startDate = Format(Date, "yyyy-mm-dd")
    endDate = Format(DateAdd("m", 1, Date), "yyyy-mm-dd")

    '// Outlookアプリケーションのセットアップ
    Set outlookApp = CreateObject("Outlook.Application")
    Set ns = outlookApp.GetNamespace("MAPI")
    Set calendarFolder = ns.GetDefaultFolder(olFolderCalendar) ' 参照設定が必要

    '// アイテムを取得し、フィルタリング
    Set items = calendarFolder.Items
    items.Sort "[Start]"
    items.IncludeRecurrences = True
    '// 日付範囲でフィルタリング
    Set filteredItems = items.Restrict("[Start] >= '" & startDate & "' AND [Start] <= '" & endDate & "'")

    '// Excelシートを準備
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Cells(1, 1).Value = "件名"
    ws.Cells(1, 2).Value = "開始日時"
    ws.Cells(1, 3).Value = "終了日時"
    ws.Cells(1, 4).Value = "場所"
    ws.Cells(1, 5).Value = "詳細"

    '// キーワードでフィルタリングして出力
    i = 2
    For Each appt In filteredItems
        If TypeOf appt Is Outlook.AppointmentItem Then
            If InStr(1, appt.Subject, keyword, vbTextCompare) > 0 Then
                ws.Cells(i, 1).Value = appt.Subject
                ws.Cells(i, 2).Value = appt.Start
                ws.Cells(i, 3).Value = appt.End
                ws.Cells(i, 4).Value = appt.Location
                ws.Cells(i, 5).Value = appt.Body
                i = i + 1
            End If
        End If
    Next appt

    MsgBox "キーワード「" & keyword & "」を含む予定をExcelに出力しました。", vbInformation

    '// オブジェクトの解放
    Set appt = Nothing
    Set filteredItems = Nothing
    Set items = Nothing
    Set calendarFolder = Nothing
    Set ns = Nothing
    Set outlookApp = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
End Sub

Public Sub AddAppointmentsFromExcel()
    Dim outlookApp As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim calendarFolder As Outlook.MAPIFolder
    Dim items As Outlook.Items
    Dim newAppt As Outlook.AppointmentItem
    Dim existingAppt As Object
    Dim ws As Worksheet
    Dim i As Long
    Dim isDuplicate As Boolean
    
    '// Excelシートの設定
    Set ws = ThisWorkbook.Sheets(1)
    
    '// Outlookアプリケーションのセットアップ
    Set outlookApp = CreateObject("Outlook.Application")
    Set ns = outlookApp.GetNamespace("MAPI")
    Set calendarFolder = ns.GetDefaultFolder(olFolderCalendar)
    Set items = calendarFolder.Items
    
    '// シート内のデータをOutlook予定表に登録
    i = 2
    Do While ws.Cells(i, 1).Value <> ""
        '// 重複チェックフラグを初期化
        isDuplicate = False
        
        '// 予定表内のアイテムを確認
        For Each existingAppt In items
            If TypeOf existingAppt Is Outlook.AppointmentItem Then
                If existingAppt.Subject = ws.Cells(i, 1).Value And _
                   existingAppt.Start = ws.Cells(i, 2).Value And _
                   existingAppt.End = ws.Cells(i, 3).Value Then
                    isDuplicate = True
                    Exit For
                End If
            End If
        Next existingAppt
        
        '// 重複がない場合のみ登録
        If Not isDuplicate Then
            Set newAppt = calendarFolder.Items.Add(olAppointmentItem)
            With newAppt
                .Subject = ws.Cells(i, 1).Value
                .Start = ws.Cells(i, 2).Value
                .End = ws.Cells(i, 3).Value
                .Location = ws.Cells(i, 4).Value
                .Body = ws.Cells(i, 5).Value
                .Save
            End With
        End If
        
        i = i + 1
    Loop
    
    MsgBox "ExcelのデータをOutlook予定表に登録しました（重複除外）。", vbInformation
    
    '// オブジェクトの解放
    Set newAppt = Nothing
    Set items = Nothing
    Set calendarFolder = Nothing
    Set ns = Nothing
    Set outlookApp = Nothing
End Sub