在共享郵箱中存檔郵件阻止他人使用Outlook

Question

我有一個用於存檔共享郵箱中的T-1電子郵件的宏。

問題是，如果我運行宏，我的所有同事都將凍結Outlook或不會發送他們的電子郵件，直到我的宏不停止。

歡迎任何幫助。

Sub Archive_Outlook_eMails() 
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder 
    Dim MailItem As Object 
    Dim SourceMailBoxName As String, DestMailBoxName As String 
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name As String 
    Dim MailsCount As Double, NumberOfDays As Double 
     Dim nam As String 
     Dim dateYear As String 
     Dim dateStr As String 

    NumberOfDays = 0 

    Source_Pst_Folder_Name = "Inbox" 
    Set SourceFolder = Session.Folders("Mailbox - Office").Folders("Inbox").Folders("Copy") 

    MailsCount = SourceFolder.Items.Count 
    While MailsCount > 0 

     Set MailItem = SourceFolder.Items.Item(MailsCount) 

     On Error GoTo FFF 

     If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) > NumberOfDays Then 

     dateStr = GetDate(MailItem.SentOn) 
     dateStr = Format(dateStr, "mmmm") 


     dateYear = GetDate(MailItem.SentOn) 
     dateYear = Format(dateYear, "yyyy") 


     nam = "Archive Office" & dateStr & " " & dateYear 

     Set DestFolder = Outlook.Session.Folders(nam).Folders("Inbox").Folders("Copy") 

      Dim myCopiedItem As Object 
      Set myCopiedItem = MailItem.Copy 
      myCopiedItem.Move DestFolder 


     End If 

FFF: 
     Dim oTemp As Object 
     If TypeName(oTemp) = "Outlook.ReportItem" Then 
     Set oMessage = oTemp 

     oMessage.Copy DestFolder 
     End If 


    Resume Next 

     MailsCount = MailsCount - 1 

    Wend 

    Call send_email_for_finish 

End Sub 

Answer 1

我相信如果其他人不能在代碼運行時工作，它是一個Outlook而不是VBA問題。

您可以通過更好的錯誤處理來緩解問題，以便代碼運行得更快。

如果出現錯誤，則錯誤處理程序不執行任何操作，並且經過多次迭代後，該項目將被複制到當前的DestFolder。

如果沒有錯誤，則該項目也會多次運行錯誤處理程序。

Sub Archive_Outlook_eMails_ErrorHandler_Demo() 

    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder 

    Dim MailItem As Object 

    'Dim SourceMailBoxName As String, DestMailBoxName As String 
    'Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name As String 

    Dim MailsCount As Double, NumberOfDays As Double 

    Dim nam As String 
    Dim dateYear As String 
    Dim dateStr As String 

    NumberOfDays = 0 

    'Source_Pst_Folder_Name = "Inbox" 

    Set SourceFolder = Session.Folders("Mailbox - Office").Folders("Inbox").Folders("Copy") 

    MailsCount = SourceFolder.Items.count 

    While MailsCount > 0 

     Set MailItem = SourceFolder.Items.Item(MailsCount) 

     On Error GoTo FFF 

     If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) > NumberOfDays Then 

      dateStr = GetDate(MailItem.SentOn) 
      dateStr = Format(dateStr, "mmmm") 

      dateYear = GetDate(MailItem.SentOn) 
      dateYear = Format(dateYear, "yyyy") 

      nam = "Archive Office" & dateStr & " " & dateYear 

      Set DestFolder = Outlook.Session.Folders(nam).Folders("Inbox").Folders("Copy") 

      Dim myCopiedItem As Object 
      Set myCopiedItem = MailItem.Copy 
      myCopiedItem.Move DestFolder 
      Debug.Print "Mailitem: " & MailsCount & " moved to DestFolder." & vbCr 

     End If 

     ' have to skip the error handling logic if you get here 

FFF: 
     Dim oTemp As Object 
     Dim oMessage As Object 

     If Err = 0 Then 
      Debug.Print " ** Err = 0: Should have skipped this error handling logic. **" 
     End If 

     ' This code is not valid 
     Debug.Print "TypeName(oTemp): " & TypeName(oTemp) 
     If TypeName(oTemp) = "Outlook.ReportItem" Then 
      Set oMessage = oTemp 
      oMessage.Copy DestFolder 
     Else 
      Debug.Print " Mailitem: " & MailsCount & " Set oMessage = oTemp was not used" & vbCr 
     End If 

     Resume Next ' ? 

     MailsCount = MailsCount - 1 

    Wend 

    'Call send_email_for_finish 

    Debug.Print "Done." 

End Sub 

在該演示中創建錯誤項的文件夾「CopyError」，所以他們有地方去。

Sub Archive_Outlook_eMails_ErrorHandlerFix_Demo() 

    Dim SourceFolder As Folder 
    Dim DestFolder As Folder 
    Dim errorFolder As Folder 

    Dim MailItem As Object 
    Dim myCopiedItem As Object 

    Dim MailsCount As Long 
    Dim NumberOfDays As Long 

    Dim nam As String 
    Dim dateYear As String 
    Dim dateStr As String 

    NumberOfDays = 0 

    Set SourceFolder = Session.Folders("Mailbox - Office").Folders("Inbox").Folders("Copy") 

    Set errorFolder = Session.Folders("Mailbox - Office").Folders("Inbox").Folders("CopyError") 

    MailsCount = SourceFolder.Items.count 

    While MailsCount > 0 

     Set MailItem = SourceFolder.Items.Item(MailsCount) 

     On Error GoTo FFF 

     If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) > NumberOfDays Then 

      dateStr = GetDate(MailItem.SentOn) 
      dateStr = Format(dateStr, "mmmm") 

      dateYear = GetDate(MailItem.SentOn) 
      dateYear = Format(dateYear, "yyyy") 

      nam = "Archive Office" & dateStr & " " & dateYear 
      Set DestFolder = Session.Folders(nam).Folders("Inbox").Folders("Copy") 

      Set myCopiedItem = MailItem.Copy 
      myCopiedItem.Move DestFolder 
      Debug.Print "Mailitem: " & MailsCount & " moved to DestFolder." & vbCr 

     End If 

returnFromErrorHandler: 

     MailsCount = MailsCount - 1 

    Wend 

    'Call send_email_for_finish 
    Debug.Print "Done" 

ExitRoutine: 
    Set MailItem = Nothing 
    Exit Sub 

FFF: 

    If Err <> 0 Then 
     Set myCopiedItem = MailItem.Copy 
     myCopiedItem.Move errorFolder 
     Debug.Print "Mailitem: " & MailsCount & " moved to errorFolder." & vbCr 

    Else 
     ' Should never get this now 
     Debug.Print "Should have skipped this error handling logic." 
     Debug.Print "Mailitem: " & MailsCount & " Set oMessage = oTemp was not used" & vbCr 

    End If 

    Resume returnFromErrorHandler 

End Sub 

Answer 2

這聽起來像您有效地需要您的代碼在後臺運行，以便Outlook用戶界面在您的處理完成之前不會被鎖定。不幸的是，這是不可能的，因爲Outlook對象不支持在後臺線程中使用。一種選擇是使用Redemption，它在比Outlook對象模型更低的級別上運行MAPI子系統，並可用於後臺線程。