如何用VBA在Outlook中提取30分钟空闲时段并插入邮件

如果你不想用Findpoll、也不愿共享整个日历，直接通过Outlook VBA就能读取自己的日历，筛选出本周/下周的30分钟空闲时段，生成符合要求的文本格式并自动创建邮件。

适配需求的VBA代码 #

Sub FindFreeTime()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim olAppt As Outlook.AppointmentItem
    Dim olItems As Outlook.Items
    Dim strFilter As String
    Dim dStart As Date
    Dim iDuration As Integer
    Dim FreeTimeMsg As String
    Dim weekOffset As Integer ' 0=本周，1=下周

    ' 配置参数：可按需修改
    iDuration = 30 ' 空闲时段时长（分钟）
    weekOffset = 0 ' 0查本周，1查下周

    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items

    ' 设定查询的时间范围：目标周的周一10:00至下周一10:00
    dStart = Date - Weekday(Date, vbMonday) + 1 + weekOffset * 7 + TimeValue("10:00:00")
    strFilter = "[Start] >= '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") & "'" _
               & " AND [Start] < '" & Format(dStart + 7, "mm/dd/yyyy hh:mm AMPM") & "'"
    Set olItems = olItems.Restrict(strFilter)
    olItems.Sort "[Start]"

    ' 遍历每个30分钟块，检查是否空闲
    Do While dStart < (Date - Weekday(Date, vbMonday) + 1 + (weekOffset + 1) * 7)
        If TimeValue(dStart) >= TimeValue("10:00:00") And TimeValue(dStart) < TimeValue("17:00:00") Then
            Set olAppt = olItems.Find("[Start] <= '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") _
                                    & "' AND [End] > '" & Format(dStart, "mm/dd/yyyy hh:mm AMPM") & "'")
            If olAppt Is Nothing Then
                ' 格式化为要求的样式：例如「5月11日周四，下午5:00-5:30」
                Dim dateStr As String, timeStartStr As String, timeEndStr As String
                dateStr = Format(dStart, "m月dd日") & " " & WeekdayName(Weekday(dStart, vbMonday), False, vbMonday)
                timeStartStr = Format(dStart, "h:mm")
                timeEndStr = Format(dStart + (iDuration / (24 * 60)), "h:mm")
                
                ' 转换为上午/下午表述
                If Hour(dStart) < 12 Then
                    timeStartStr = "上午" & timeStartStr
                    timeEndStr = "上午" & timeEndStr
                Else
                    timeStartStr = "下午" & timeStartStr
                    timeEndStr = "下午" & timeEndStr
                End If
                
                FreeTimeMsg = FreeTimeMsg & dateStr & "，" & timeStartStr & "-" & timeEndStr & vbCrLf
            End If
        End If
        dStart = dStart + (iDuration / (24 * 60))
    Loop

    ' 创建新邮件并填充空闲时段
    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .Subject = IIf(weekOffset = 0, "本周", "下周") & "我的30分钟空闲时段"
        .Body = "以下是" & IIf(weekOffset = 0, "本周", "下周") & "我的30分钟空闲时段：" & vbCrLf & vbCrLf & FreeTimeMsg
        .Display
    End With

    ' 释放对象
    Set olAppt = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

运行步骤 #

1. 打开Outlook，按下Alt + F11打开VBA编辑器
2. 在左侧「项目」面板中，右键点击你的Outlook项目，选择「插入」→「模块」
3. 将上述代码粘贴到新建的模块中
4. 按下F5运行宏，或者回到Outlook，通过「开发工具」→「宏」选择FindFreeTime执行

关键调整说明 #

• 周切换：修改weekOffset变量，0代表本周，1代表下周
• 格式适配：代码自动将日期时间转换为你要求的「X月X日周X，上午/下午X:XX-X:XX」样式
• 时间范围：默认查询10:00-17:00的工作时段，可直接修改代码中的TimeValue值调整
• 隐私保障：仅读取你的默认日历，不会对外共享任何日历数据

注意事项 #

• 需确保Outlook允许宏运行：依次打开「文件」→「选项」→「信任中心」→「信任中心设置」→「宏设置」，选择「启用所有宏」或「通知我启用宏」
• 可根据需求修改iDuration变量，调整空闲时段的时长

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