VBA - Outlook 2010 - 在受工作周和办公时间限制的计算中使用电子邮件的 ReceivedTime

VBA - Outlook 2010 - Using ReceivedTime of email in calculation constrained by work week and office hours

提问by bendeavour

I'm trying to develop a module in Outlook that can use the ReceivedTime of an email and then add x hours to it to give a 'response time'. The hours added though have to be within the working week (Mon-Fri) and the office hours (9-5).

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

For my case, x can be declared a constant of 36 hours, however (as below) I don't know how to write the code for this with the constraints of the work week and office hours.

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

I was able to write a basic module that adds 100 hours, as this can give the correct response time in some cases.

我能够编写一个增加 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

Any help would be greatly appreciated, thank you :)

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

回答by David Zemens

OK, so to do this you're going to need to work with some of the Date & Time functions I mentioned above. I am not certain this will account for Holidays -- actually, I'm pretty sure it will not, since those vary by locale, and even by business. In any case this should get you 99% of the way there:

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

You should be able to call this function in your macro by:

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

LDate = GetTargetDate(myMail.ReceivedTime, 36)

LDate = GetTargetDate(myMail.ReceivedTime, 36)

I include a test subroutine, so you can plug in a date/time and see what results:

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

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

Here is the function, place it within your code module:

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

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

This yields the following:

这产生以下结果：

If email is received during business hours:

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

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

If email is received during business hours, but the deadline becomes after business hours or on weekend, carry the remainder :

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

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

If a mail is received before business hours, consider it received at 9:00:00 AM :

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

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

If a mail is received after business hours, consider it received at 9:00:00 AM the following business day:

如果在工作时间后收到邮件，请考虑在下一个工作日上午 9:00:00 收到邮件：

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

And also works if the mail is received on the weekend, consider it received at 9:00:00 AM on Monday:

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

Received at 6/1/2013 12:06:00 PM
Due by 6/7/2013 1:00:00 PM