如何将编辑后的Outlook AppointmentItem数据同步至Access表单控件

我有一个Access表单，可为当前记录创建Outlook AppointmentItem，该AppointmentItem的.Start和.Categories属性值来自表单上的用户输入。我设置了一个命令按钮，可查找并打开该AppointmentItem供用户编辑。

希望用户完成编辑后，将修改后的信息传递到表单控件中，使用户无需打开AppointmentItem就能查看更新后的开始时间和类别。

我使用公共变量存储这两项数据，但代码运行后，表单控件并未反映存储在公共变量中的值。只有再次通过代码打开并关闭AppointmentItem（无论是否保存），表单控件才会更新。

查找AppointmentItem的函数代码 #

Option Compare Database
Public gdtStart As Date
Public gstrCat As String
Option Explicit

Function FindExistingAppt(strPath As String)
    
    Dim OApp        As Object
    Dim OAppt       As Object
    Dim ONS         As Object
    Dim ORecipient  As Outlook.Recipient
    Dim OFolder     As Object
    Dim sFilter     As String
    
    Const olAppointmentItem = 1
    Dim bAppOpened            As Boolean
    'Initiate our instance of the oApp object so we can interact with Outlook
    On Error Resume Next
    Set OApp = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        err.Clear
        Set OApp = CreateObject("Outlook.Application")
        bAppOpened = False    'Outlook was not already running, we had to start it
    Else
        bAppOpened = True    'Outlook was already running
    End If
    On Error GoTo Error_Handler
        
    Set OApp = GetObject(, "Outlook.Application")
    Set ONS = OApp.GetNamespace("MAPI")
        
    Set ORecipient = ONS.CreateRecipient("xxxxxxxxxxxxx")
        
    'my example uses a shared folder but you can change it to your default
    Set OFolder = ONS.GetSharedDefaultFolder(ORecipient, olFolderCalendar)
    'use your ID here
    sFilter = "[Mileage] = " & strPath & ""
        
    If Not OFolder Is Nothing Then
        
        Set OAppt = OFolder.Items.Find(sFilter)
        
        If OAppt Is Nothing Then
            MsgBox "Could not find appointment"
        Else
            With OAppt
                .Display
            End With
        End If
    End If

    gdtStart = OAppt.Start
    gstrCat = OAppt.Categories
        
Error_Handler_Exit:
    On Error Resume Next
    If Not OAppt Is Nothing Then Set OAppt = Nothing
    If Not OApp Is Nothing Then Set OApp = Nothing
    Exit Function
     
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
      "Error Number: " & err.Number & vbCrLf & _
      "Error Source: FindExistingAppt" & vbCrLf & _
      "Error Description: " & err.Description & _
      Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl), _
      vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
    
End Function

命令按钮点击事件代码 #

Private Sub cmdFindAppt_Click()
'Goes to the OutlookApp module and uses the FindExistingAppt function to look for an appointment that has
'already been created to the Warrants Outlook calendar, and if it found, opens the appointment. After edits are
'made the Appointment Date and Category are updated on the form.
    Call FindExistingAppt(Me.ID)
    Me.ApptDate = gdtStart
    Me.Category = gstrCat
End Sub

问题核心是.Display方法默认是非阻塞的：代码执行到.Display后会立刻继续往下走，此时用户还没完成编辑，读取的是旧值。需要改成阻塞式显示，等用户关闭约会窗口后再读取更新后的数据。

1. 修改约会窗口的显示方式 #

将FindExistingAppt函数中的显示代码：

With OAppt
    .Display
End With

替换为：

With OAppt
    .Display (True) ' 参数True设置为模态窗口，阻塞代码直到窗口关闭
End With

2. 优化公共变量赋值逻辑（避免空对象错误） #

把公共变量的赋值放到约会存在的分支里，同时处理约会不存在的情况：

If OAppt Is Nothing Then
    MsgBox "Could not find appointment"
    ' 重置公共变量避免旧值干扰
    gdtStart = #1/1/1900#
    gstrCat = ""
Else
    With OAppt
        .Display (True)
        ' 窗口关闭后读取最新值
        gdtStart = .Start
        gstrCat = .Categories
    End With
End If

这样可以避免约会不存在时OAppt为空导致的运行时错误。

3. 命令按钮代码无需修改 #

现在函数会等待用户关闭约会窗口后再返回，按钮代码赋值的就是最新的编辑结果，表单控件会直接显示更新后的数据。

内容的提问来源于stack exchange，提问作者MrT 158