使用VBA获取共享邮箱近24小时未回复邮件的代码问题

• 业务需求：从仅持有代发权限、非所有者的Outlook共享邮箱中，筛选出近24小时未得到回复的邮件
• 现有代码故障：无法成功保存搜索文件夹；筛选逻辑未加入24小时时间范围限制，返回结果不符合预期

• 代码存在冗余逻辑：重复创建共享邮箱收件人对象，且未判断收件人解析有效性，容易出现共享邮箱路径获取失败的问题
• DASL筛选语法错误：逻辑运算符AND前后未加空格，会导致筛选条件解析失败；同时原有回复状态判断未覆盖转发场景，筛选结果不准确
• 异步操作逻辑错误：AdvancedSearch是异步执行方法，原代码未等搜索完成就直接执行保存动作，是搜索文件夹保存失败的核心原因
• 语法不兼容：VBA不支持//格式的注释，原代码注释写法不符合规范
• 筛选逻辑缺失：未加入24小时时间范围的判断条件，无法匹配需求

Sub CreateSearchFolder_AllNotRepliedEmails()
    Dim OutlookApp As Outlook.Application
    Dim strScope As String
    Dim OutlookNamespace As Outlook.NameSpace
    Dim strRepliedProperty As String
    Dim strReceivedTimeProperty As String
    Dim strFilter As String
    Dim objSearch As Outlook.Search
    Dim objOwner As Outlook.Recipient
    Dim sharedInbox As Outlook.MAPIFolder
    Dim cutoffTime As Date
    Dim waitCount As Integer
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' 初始化共享邮箱收件人，判断是否解析成功
    Set objOwner = OutlookNamespace.CreateRecipient("Sdk@dau.ae")
    objOwner.Resolve
    If Not objOwner.Resolved Then
        MsgBox "无法解析共享邮箱地址，请确认权限", vbCritical
        Exit Sub
    End If
    
    ' 获取共享邮箱收件箱路径，设置搜索范围
    Set sharedInbox = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
    strScope = "'" & sharedInbox.FolderPath & "'"
    
    ' 计算24小时前的时间节点
    cutoffTime = Now() - 1
    ' 配置属性：PR_LAST_VERB_EXECUTED 记录邮件最后执行的动作（回复/转发等）
    strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    ' 配置属性：邮件接收时间
    strReceivedTimeProperty = "urn:schemas:httpmail:datereceived"
    
    ' 拼接筛选条件：未执行回复/转发动作，且接收时间早于24小时前
    ' 如果需要筛选【近24小时内收到的未回复邮件】，把下面的 <= 改成 >= 即可
    strFilter = "NOT " & Chr(34) & strRepliedProperty & Chr(34) & " = 102" & _
                " AND NOT " & Chr(34) & strRepliedProperty & Chr(34) & " = 103" & _
                " AND NOT " & Chr(34) & strRepliedProperty & Chr(34) & " = 104" & _
                " AND " & Chr(34) & strReceivedTimeProperty & Chr(34) & " <= '" & _
                Format(cutoffTime, "mm/dd/yyyy hh:nn:ss") & "'"
    
    ' 执行高级搜索
    Set objSearch = OutlookApp.AdvancedSearch( _
        Scope:=strScope, _
        Filter:=strFilter, _
        SearchSubFolders:=True, _
        Tag:="NotRepliedSearch")
    
    ' 等待搜索完成，避免异步操作未结束就保存导致失败
    waitCount = 0
    Do While objSearch.Results.Count = 0 And waitCount < 20
        DoEvents
        waitCount = waitCount + 1
        Application.Wait Now + TimeValue("00:00:01")
    Loop
    
    ' 保存搜索文件夹，增加重复存在的错误处理
    On Error Resume Next
    objSearch.Save "Sd email not Replied"
    If Err.Number <> 0 Then
        MsgBox "搜索文件夹已存在或保存失败：" & Err.Description, vbExclamation
    Else
        MsgBox "搜索文件夹创建成功！", vbInformation
    End If
    On Error GoTo 0
End Sub

• 移除冗余的收件人创建逻辑，新增共享邮箱地址解析有效性判断，从源头避免路径获取失败问题
• 重构DASL筛选语句，补全必要的语法空格，同时覆盖已回复、已全部回复、已转发三类已处理状态，提升筛选准确性
• 新增24小时时间范围计算逻辑，将时间转换为Outlook DASL筛选兼容的格式，默认筛选「24小时前收到、至今未做回复/转发处理」的邮件，如果需要调整为「近24小时内收到的未回复邮件」，仅需将筛选条件中时间判断的<=运算符修改为>=即可
• 新增搜索完成等待逻辑，轮询搜索结果加载状态，确保异步搜索完成后再执行保存动作；同时新增错误捕获，处理同名搜索文件夹已存在的场景，解决保存失败问题
• 修正所有注释为VBA标准的单引号格式，避免语法兼容问题

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