如何为Outlook日历处理宏的进度条/状态栏添加剩余时间显示

要在进度条（或状态栏）里展示剩余时间，我们可以通过已处理行数的占比 + 已消耗时间来预估总运行时长，再用总时长减去已用时间得到剩余时间。下面是修改后的完整代码，我会标注关键改动：

首先，你可以选择在用户窗体ufProgress里添加一个额外的标签控件（比如命名为LabelTimeRemaining）专门显示剩余时间；如果不想新增控件，直接把剩余时间追加到现有LabelCaption里也完全可行。

修改后的代码 #

Sub DeleteAfterResponseCoring()
    Dim i As Long, j As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objAppointment As Outlook.AppointmentItem
    Set objOutlook = Outlook.Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
    Set oItems = objFolder.Items
    Set wb = ThisWorkbook
    Set ws = ThisWorkbook.ActiveSheet
    Dim StartTime As Double
    Dim MinutesElapsed As String
    Dim TimeElapsed As Double
    Dim EstimatedTotalTime As Double
    Dim TimeRemaining As String
    
    '记录宏启动时间
    StartTime = Timer
    Dim r As Long
    Dim pctdone As Single
    r = ws.Cells(Rows.Count, 2).End(xlUp).Row
    
    '(Step 1) 显示进度条
    ufProgress.LabelProgress.Width = 0
    ufProgress.Show
    
    For i = 3 To r
        '(Step 2) 计算时间指标，预估剩余时间
        TimeElapsed = Timer - StartTime
        '修正进度计算：循环从第3行开始，总处理行数为r-2
        pctdone = (i - 2) / (r - 2)
        
        '避免初始阶段除以0的报错，先判断进度占比
        If pctdone > 0 Then
            EstimatedTotalTime = TimeElapsed / pctdone
            '格式化剩余时间为hh:mm:ss格式
            TimeRemaining = Format((EstimatedTotalTime - TimeElapsed) / 86400, "hh:mm:ss")
        Else
            TimeRemaining = "Calculating..." '初始阶段显示占位文本
        End If
        
        '(Step 3) 更新进度条，追加时间信息
        With ufProgress
            .LabelCaption.Caption = "Processing Row " & i & " of " & r & vbCrLf & _
                                    "已用时间: " & Format(TimeElapsed / 86400, "hh:mm:ss") & vbCrLf & _
                                    "剩余时间: " & TimeRemaining & vbCrLf & _
                                    "完成后可关闭窗口。"
            .LabelProgress.Width = pctdone * (.FrameProgress.Width)
        End With
        DoEvents
        
        '-------核心业务逻辑保留-------
        For j = oItems.Count To 1 Step -1
            If (ActiveSheet.Name) = "Coring" And ws.Cells(i, 11).Value = "N/A" And ws.Cells(i, 8).Value = "Yes" Then
                ws.Cells(i, 15) = "Yes"
                Set objAppointment = oItems.Item(j)
                With objAppointment
                    If .Subject = "Send reminder email - LBR " + ws.Cells(i, 3).Value Or .Subject = "FINAL DEADLINE - LBR " + ws.Cells(i, 2).Value Then
                        objAppointment.Delete
                    End If
                End With
            End If
        Next j
    Next i
    
    Unload ufProgress
    
    '计算总运行时长并提示
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "代码执行成功，总耗时: " & MinutesElapsed, vbInformation
End Sub

关键改动说明： #

1. 新增时间计算变量：添加了TimeElapsed（已用时间）、EstimatedTotalTime（预估总时长）、TimeRemaining（格式化后的剩余时间）三个变量，专门处理时间逻辑。
2. 修正进度占比计算：原代码的pctdone = i / r会导致进度条提前跳至100%，改成pctdone = (i - 2)/(r - 2)后，进度计算更准确（因为循环从第3行开始，总处理行数为r-2）。
3. 剩余时间预估逻辑：
   • 当已处理部分行（pctdone > 0）时，用已用时间除以进度占比得到预估总时长，再减去已用时间得到剩余时间。
   • 初始循环时进度为0，显示"Calculating..."避免除以0的报错。
4. 进度条文本优化：把已用时间和剩余时间追加到进度条标题中，让用户能直观看到时间信息。

额外选项：显示在Excel状态栏 #

如果不想修改用户窗体，也可以把剩余时间显示在Excel状态栏里，只需要在DoEvents之前添加一行代码：

Application.StatusBar = "Processing Row " & i & " of " & r & " | 剩余时间: " & TimeRemaining

记得在宏结束后重置状态栏，避免影响后续操作：

Application.StatusBar = False

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