VBA - Outlook 2010 - 在計算限制的工作周和辦公時間使用ReceivedTime電子郵件

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

好了，要做到這一點，你會需要一些我上面提到的日期&時間函數的工作。我不確定這是否會導致假期 - 事實上，我很確定它不會，因爲這些因地區而異，甚至因業務而異。在任何情況下，本應該讓你的存在方式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 

如果之前營業時間收到的郵件，認爲這是在上午09時00分○○秒獲得：

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

如果營業時間後收到一個郵件，認爲這是在上午09時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