0

我正在尝试在 Outlook 中开发一个模块，该模块可以使用电子邮件的 ReceivedTime，然后向其添加 x 小时以给出“响应时间”。增加的时间必须在工作周（周一至周五）和办公时间（9-5）内。

就我而言，x 可以声明为 36 小时的常数，但是（如下所示）我不知道如何在工作周和办公时间的限制下为此编写代码。

我能够编写一个增加 100 小时的基本模块，因为这在某些情况下可以提供正确的响应时间。

Sub TargetResolution()
Dim myMail As Outlook.MailItem

For Each myMail In Application.ActiveExplorer.Selection

Dim LDate As Date

LDate = DateAdd("h", 100, myMail.ReceivedTime)

MsgBox "Time Received: " & (myMail.ReceivedTime) & Chr(13) & "Target Resolution: " & (LDate)
Next

Set myMail = Nothing
End Sub

任何帮助将不胜感激，谢谢:)

4

1 回答 1

4

好的，所以要做到这一点，您将需要使用我上面提到的一些日期和时间函数。我不确定这是否会考虑假期——实际上，我很确定不会，因为这些因地区而异，甚至因业务而异。无论如何，这应该可以让您完成 99% 的工作：

您应该能够通过以下方式在宏中调用此函数：

LDate = GetTargetDate(myMail.ReceivedTime, 36)

我包含一个测试子程序，因此您可以插入日期/时间并查看结果：

Sub TestDate()
    Dim dt As Date

    dt = "6/1/2013 12:06:00 PM"

    Debug.Print "Received at " & dt
    Debug.Print "Due by " & GetTargetDate(dt, 36)

End Sub

这是函数，将其放在您的代码模块中：

Option Explicit
Const startDay As String = " 9:00:00 AM"
Const endDay As String = " 5:00:00 PM"
Const hrsPerDay As Long = 8
Function GetTargetDate(myDate As Date, numHours As Long) As Date
    Dim effRecdDate As Date
    Dim newDate As Date
    Dim resolveDays As Double 'number of hours, converted to full days
    Dim resolveHours As Long
    Dim hh As Long

    resolveDays = numHours / hrsPerDay 'convert to days

    '## Ensure the timestamp is within business hours
    effRecdDate = ValidBizHours(myDate)

    '## Ensure the date is a business day
    effRecdDate = ValidWeekday(myDate)

    'Convert to hours, carrying the partial day as a fraction of the 8-hr workday
    resolveHours = (Int(resolveDays) * 24) + numHours Mod hrsPerDay

    '## Add each of the resolveHours, but if the result is not a weekday, then
    ' add another day
    For hh = 1 To resolveHours
        newDate = DateAdd("h", hh, effRecdDate)
        If Weekday(newDate, vbMonday) > 5 Then
            effRecdDate = DateAdd("d", 1, effRecdDate)
        End If
    Next

    '## Make sure this date falls between biz hours AND that
    ' it consequently falls on a business DAY
    Do
        If TimeValue(newDate) > TimeValue(startDay) And TimeValue(newDate) < TimeValue(endDay) Then
            If Weekday(newDate, vbMonday) <= 5 Then
                Exit Do
            Else:
                newDate = DateAdd("d", 1, newDate)
            End If
        Else:
            newDate = DateAdd("h", 1, newDate)
        End If
    Loop

    '## Return the newDate to the function:
    GetTargetDate = newDate
End Function
Private Function ValidWeekday(myDate As Date) As Date
    'Converts timestamps received on the weekend to Monday morning, 9:00:00 AM
    Do While Weekday(myDate, vbMonday) > 5
        myDate = DateValue(DateAdd("d", 1, myDate)) & startDay
    Loop
    ValidWeekday = myDate
End Function

Private Function ValidBizHours(myDate As Date) As Date
    'Converts timestamps after business hours to 9:00:00 AM the following day
    'Converts timestamps before business hours to 9:00:00 AM same business day
    Select Case TimeValue(myDate)
        Case Is > TimeValue(endDay)
            'Assume this is received at start of the following day:
            myDate = DateValue(DateAdd("d", 1, myDate)) & startDay
        Case Is < TimeValue(startDay)
            'Assume this is received at start of day, but not earlier:
            myDate = DateValue(myDate) & startDay
        Case Else
            'do nothing
    End Select
    ValidBizHours = myDate
End Function

这会产生以下结果：

如果在工作时间收到电子邮件：

Received at 5/27/2013 9:06:00 AM
Due by 5/31/2013 1:06:00 PM

如果在工作时间收到电子邮件，但截止日期是在工作时间之后或周末，请携带剩余部分：

Received at 5/30/2013 1:06:00 PM
Due by 6/6/2013 9:06:00 AM

如果在工作时间之前收到邮件，则认为它是在上午 9:00:00 收到的：

Received at 5/27/2013 7:06:00 AM
Due by 5/31/2013 1:00:00 PM

如果在工作时间以外收到邮件，则认为它是在下一个工作日上午 9:00:00 收到的：

Received at 5/27/2013 9:06:00 PM
Due by 6/3/2013 1:00:00 PM

如果邮件是在周末收到的，也可以使用，假设它是在周一上午 9:00:00 收到的：

Received at 6/1/2013 12:06:00 PM
Due by 6/7/2013 1:00:00 PM
于 2013-05-29T01:41:58.450 回答