开发Outlook每日出勤调研宏：9点弹窗收集办公地点并汇总至Excel

完全可以通过Outlook定期约会+VBA事件实现你的需求，以下是具体实现步骤：

一、创建触发提醒的定期约会 #

1. 打开Outlook，新建一个约会
2. 设置主题为办公状态上报提醒（后续VBA会通过这个主题识别目标约会）
3. 设置开始时间为每天上午9:00，结束时间可设为9:05（不影响提醒触发）
4. 在「重复周期」中设置为每天重复，无结束日期
5. 开启提醒，提醒时间设为「约会开始时」（确保9点准时触发）
6. 保存约会

二、编写Outlook VBA代码 #

打开Outlook的VBA编辑器（按Alt+F11），在ThisOutlookSession模块中粘贴以下代码：

Private WithEvents olReminders As Outlook.Reminders

' 启动Outlook时初始化提醒事件监听
Private Sub Application_Startup()
    Set olReminders = Outlook.Application.Reminders
End Sub

' 提醒触发时执行的逻辑
Private Sub olReminders_ReminderFire(ByVal ReminderObject As Reminder)
    ' 仅处理指定主题的约会提醒
    If ReminderObject.Item.Subject = "办公状态上报提醒" Then
        Dim userChoice As VbMsgBoxResult
        userChoice = MsgBox("请选择今日办公状态：" & vbCrLf & "【是】= 到岗办公" & vbCrLf & "【否】= 居家办公", _
                            vbYesNo + vbQuestion, "每日办公状态上报")
        
        Dim statusText As String
        statusText = IIf(userChoice = vbYes, "到岗办公", "居家办公")
        
        ' 发送状态邮件给指定收件人
        SendStatusNotification statusText
        
        ' 实时写入Excel记录（后续每日汇总可基于此文件）
        LogStatusToExcel Date, statusText
    End If
End Sub

' 发送状态通知邮件
Private Sub SendStatusNotification(status As String)
    Dim mailItem As Outlook.MailItem
    Set mailItem = Outlook.Application.CreateItem(olMailItem)
    
    With mailItem
        .To = "你的收件邮箱@xxx.com" ' 替换为接收状态的邮箱
        .Subject = "[" & Format(Date, "yyyy-MM-dd") & "] 办公状态上报"
        .Body = "今日办公状态：" & status & vbCrLf & "上报时间：" & Format(Now(), "yyyy-MM-dd HH:mm:ss")
        .Send
    End With
    Set mailItem = Nothing
End Sub

' 将状态写入Excel汇总表
Private Sub LogStatusToExcel(reportDate As Date, status As String)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim lastRow As Long
    Dim excelPath As String
    
    ' 替换为你的Excel汇总文件路径
    excelPath = "C:\WorkStatus\办公状态汇总.xlsx"
    
    ' 尝试获取已运行的Excel实例，无则新建
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    xlApp.Visible = False ' 后台运行避免干扰
    
    ' 打开指定Excel文件
    Set xlWB = xlApp.Workbooks.Open(excelPath)
    Set xlWS = xlWB.Sheets("每日记录") ' 替换为你的工作表名称
    
    ' 定位到最后一行空白行
    lastRow = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).Row ' -4162对应Excel的xlUp常量
    
    ' 写入数据
    xlWS.Cells(lastRow + 1, "A").Value = reportDate
    xlWS.Cells(lastRow + 1, "B").Value = status
    xlWS.Cells(lastRow + 1, "C").Value = Now()
    
    ' 保存并关闭Excel
    xlWB.Save
    xlWB.Close
    xlApp.Quit
    
    ' 释放对象
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

三、每日结束汇总补充（可选） #

如果需要每日结束自动整理汇总数据（比如统计当日/当月到岗/居家次数），可以再创建一个每天18:00的定期约会，主题设为办公状态汇总整理，然后在olReminders_ReminderFire事件中添加以下判断逻辑：

ElseIf ReminderObject.Item.Subject = "办公状态汇总整理" Then
    ' 触发汇总逻辑
    GenerateDailySummary
End If

对应的汇总子过程示例：

Private Sub GenerateDailySummary()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim dailyWS As Object
    Dim lastRow As Long
    Dim excelPath As String
    
    excelPath = "C:\WorkStatus\办公状态汇总.xlsx"
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    xlApp.Visible = True ' 显示Excel方便查看汇总结果
    
    Set xlWB = xlApp.Workbooks.Open(excelPath)
    Set xlWS = xlWB.Sheets("每日记录")
    Set dailyWS = xlWB.Sheets("每日汇总") ' 确保存在这个工作表
    
    lastRow = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).Row
    
    ' 计算当日到岗/居家次数（单人场景，多人可扩展）
    Dim workFromOffice As Long
    Dim workFromHome As Long
    
    workFromOffice = xlApp.WorksheetFunction.CountIfs(xlWS.Range("A:A"), Date, xlWS.Range("B:B"), "到岗办公")
    workFromHome = xlApp.WorksheetFunction.CountIfs(xlWS.Range("A:A"), Date, xlWS.Range("B:B"), "居家办公")
    
    ' 写入汇总表
    Dim summaryRow As Long
    summaryRow = dailyWS.Cells(dailyWS.Rows.Count, "A").End(-4162).Row + 1
    
    dailyWS.Cells(summaryRow, "A").Value = Date
    dailyWS.Cells(summaryRow, "B").Value = workFromOffice
    dailyWS.Cells(summaryRow, "C").Value = workFromHome
    
    xlWB.Save
    xlWB.Close
    xlApp.Quit
    
    Set dailyWS = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

四、关键注意事项 #

• 确保Outlook始终处于运行状态，否则约会提醒无法触发
• 在Outlook信任中心启用宏（文件→选项→信任中心→信任中心设置→宏设置→启用所有宏）
• Excel文件路径需确保有读写权限，首次运行前可手动创建该文件及对应工作表
• 定期约会不要被删除或修改主题，否则VBA无法识别

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