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 UI。遗憾的是，由于不支持在后台线程中使用Outlook对象，因此无法进行此操作。一种选择是使用Redemption，它在MAPI子系统上运行，其级别低于Outlook对象模型，可以在后台线程中使用。

共享邮箱中的存档邮件会阻止其他人使用Outlook

2 个答案: