Question

我正在尝试在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

非常感谢任何帮助，谢谢：）

Answer 1

好的，所以要做到这一点，你需要使用一些Date＆amp;我上面提到的时间函数。我不确定这会占到假期 - 实际上，我很确定它不会，因为这些因地区，甚至商业而异。在任何情况下，这应该让你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

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

1 个答案: