outlookからAccessに予定表をインポートする方法

Sub ImportCalendarsFromAccessUserList()
    Dim oApp As Object
    Dim oNS As Object
    Dim oFolder As Object
    Dim oItems As Object
    Dim oAppt As Object
    Dim ws As DAO.Workspace
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim rsUsers As DAO.Recordset
    Dim sFilter As String
    Dim oRestrictItems As Object
    Dim importedItems As Object
    Dim key As String
    Dim userEmail As String
    
    ' デフォルトのWorkspaceを取得
    Set ws = DBEngine.Workspaces(0)
    
    ' データベース接続
    Set db = ws.OpenDatabase("YourDatabaseName")
    Set rs = db.OpenRecordset("YourTableName", dbOpenDynaset)
    Set rsUsers = db.OpenRecordset("UserListTableName", dbOpenSnapshot) ' ユーザーリストテーブルを開く
    
    ' Outlookアプリケーションのインスタンスを作成
    Set oApp = CreateObject("Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    
    ' 辞書の作成
    Set importedItems = CreateObject("Scripting.Dictionary")
    
    On Error GoTo ErrorHandler
    
    ' トランザクション開始
    ws.BeginTrans
    
    ' ユーザーリストをループ
    Do While Not rsUsers.EOF
        userEmail = rsUsers!Email
        
        ' 各ユーザーの予定表を取得
        Set oFolder = oNS.GetSharedDefaultFolder(oNS.CreateRecipient(userEmail), 9) ' 9は予定表のフォルダID
        Set oItems = oFolder.Items
        
        ' インポートする項目をフィルタリングする
        oItems.Sort "[Start]"
        oItems.IncludeRecurrences = True
        
        ' フィルタを設定（例：過去1ヶ月間の予定を取得）
        sFilter = "[Start] >= '" & Format(DateAdd("m", -1, Now), "dd/mm/yyyy hh:mm AMPM") & "'"
        Set oRestrictItems = oItems.Restrict(sFilter)
        
        For Each oAppt In oRestrictItems
            ' 辞書のキーを設定（例：開始時間と件名の組み合わせ）
            key = Format(oAppt.Start, "yyyymmddhhmm") & "-" & oAppt.Subject
            
            ' 辞書にキーが存在するか確認
            If Not importedItems.Exists(key) Then
                rs.AddNew
                rs!Subject = oAppt.Subject
                rs!Start = oAppt.Start
                rs!End = oAppt.End
                rs!Location = oAppt.Location
                rs.Update
                
                ' 辞書に追加
                importedItems.Add key, True
            End If
        Next oAppt
        
        ' 次のユーザーに移動
        rsUsers.MoveNext
    Loop
    
    ' トランザクションをコミット
    ws.CommitTrans
    
    ' クリーンアップ
    rsUsers.Close
    rs.Close
    Set rsUsers = Nothing
    Set rs = Nothing
    Set db = Nothing
    Set ws = Nothing
    Set oRestrictItems = Nothing
    Set oItems = Nothing
    Set oFolder = Nothing
    Set oNS = Nothing
    Set oApp = Nothing
    Set importedItems = Nothing

    MsgBox "Import completed successfully."
    Exit Sub

ErrorHandler:
    ' エラーが発生した場合、トランザクションをロールバック
    ws.Rollback
    MsgBox "Error occurred: " & Err.Description
    Resume Next
End Sub