Vba 在共享邮箱中存档邮件，防止其他人使用Outlook

我有一个宏，用于存档来自共享邮箱的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

---

我相信如果其他人在代码运行时无法工作，这是Outlook的问题，而不是VBA的问题

您可以通过更好的错误处理来缓解问题，从而使代码运行更快

如果出现错误，错误处理程序将不执行任何操作，并在多次迭代后将该项复制到当前文件夹

如果没有错误，该项也会在错误处理程序中运行多次

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

Sub-Archive\u Outlook\u email\u ErrorHandlerFix\u Demo（）
将SourceFolder设置为文件夹
将文件夹设置为文件夹
将文件夹设置为文件夹
将邮件项设置为对象
作为对象的隐孢子虫
暗色的邮筒和长的一样
暗淡的数天一样长
将nam作为字符串
将dateYear设置为字符串
Dim dateStr作为字符串
NumberOfDays=0
设置SourceFolder=Session.Folders（“邮箱-办公室”）.Folders（“收件箱”）.Folders（“副本”）
Set errorFolder=Session.Folders（“邮箱-办公室”）.Folders（“收件箱”）.Folders（“复制错误”）
MailsCount=SourceFolder.Items.count
而MailsCount>0
设置MailItem=SourceFolder.Items.Item（MailScont）
关于错误转到FFF
如果VBA.DateValue（VBA.Now）-VBA.DateValue（MailItem.ReceivedTime）>天数，则
dateStr=GetDate（MailItem.SentOn）
dateStr=格式（dateStr，“mmmm”）
dateYear=GetDate（MailItem.SentOn）
dateYear=格式（dateYear，“yyyy”）
nam=“档案室”&dateStr&&dateYear
设置DestFolder=Session.Folders（nam）.Folders（“收件箱”）.Folders（“复制”）
设置myCopiedItem=MailItem.Copy
mycopidetem.Move dest文件夹
调试。打印“Mailitem:”&MailsCount&“移动到DestFolder.”&vbCr
如果结束
returnFromErrorHandler：
mailscont=mailscont-1
温德
'呼叫发送电子邮件以完成
调试。打印“完成”
现存的：
设置MailItem=Nothing
出口接头
FFF：
如果错误为0，则
设置myCopiedItem=MailItem.Copy
myCopiedItem.Move error文件夹
调试。打印“Mailitem:”&MailsCount&“移动到错误文件夹”。&vbCr
其他的
“我现在不应该得到这个
“Debug.Print”应跳过此错误处理逻辑
Debug.Print“Mailitem:&MailsCount&“未使用Set-oMessage=oTemp”&vbCr
如果结束
从ErrorHandler恢复返回
端接头

我相信如果其他人在代码运行时无法工作，那是Outlook的问题，而不是VBA的问题

您可以通过更好的错误处理来缓解问题，从而使代码运行更快

如果出现错误，错误处理程序将不执行任何操作，并在多次迭代后将该项复制到当前文件夹

如果没有错误，该项也会在错误处理程序中运行多次

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

Sub-Archive\u Outlook\u email\u ErrorHandlerFix\u Demo（）
将SourceFolder设置为文件夹
将文件夹设置为文件夹
将文件夹设置为文件夹
将邮件项设置为对象
作为对象的隐孢子虫
暗色的邮筒和长的一样
暗淡的数天一样长
将nam作为字符串
将dateYear设置为字符串
Dim dateStr作为字符串
NumberOfDays=0
设置SourceFolder=Session.Folders（“邮箱-办公室”）.Folders（“收件箱”）.Folders（“副本”）
Set errorFolder=Session.Folders（“邮箱-办公室”）.Folders（“收件箱”）.Folders（“复制错误”）
MailsCount=SourceFolder.Items.count
而MailsCount>0
设置MailItem=SourceFolder.Items.Item（MailScont）
关于错误转到FFF
如果VBA.DateValue（VBA.Now）-VBA.DateValue（MailItem.ReceivedTime）>天数，则
dateStr=GetDate（MailItem.SentOn）
dateStr=格式（dateStr，“mmmm”）
dateYear=GetDate（MailItem.SentOn）
dateYear=格式（dateYear，“yyyy”）
nam=“档案室”&dateStr&&dateYear
设置DestFolder=Session.Folders（nam）.Folders（“收件箱”）.Folders（“复制”）
设置myCopiedItem=MailItem.Copy
mycopidetem.Move dest文件夹
调试。打印“Mailitem:”&MailsCount&“移动到DestFolder.”&vbCr
如果结束
returnFromErrorHandler：
mailscont=mailscont-1
温德
'呼叫发送电子邮件以完成
调试。打印“完成”
现存的：
设置MailItem=Nothing
出口接头
FFF：
如果错误为0，则
设置myCopiedItem=MailItem.Copy
myCopiedItem.Move error文件夹
调试。打印“Mailitem:”&MailsCount&“移动到错误文件夹”。&vbCr
其他的
“我现在不应该得到这个
“Debug.Print”应跳过此错误处理逻辑
Debug.Print“Mailitem:&MailsCount&“未使用Set-oMessage=oTemp”&vbCr
如果结束
从ErrorHandler恢复返回
端接头

听起来您实际上需要在后台运行代码，以便在处理完成之前不会锁定Outlook UI。不幸的是，这是不可能的，因为Outlook对象不支持在后台线程中使用。一个选项是使用，它在MAPI子系统上的操作级别低于Outlook对象模型，可以在后台线程中使用。

听起来您实际上需要在后台运行代码，以便在处理完成之前不会锁定Outlook UI。不幸的是，这是不可能的，因为Outlook对象不支持在后台线程中使用。一个选项是使用，它在MAPI子系统上的操作级别低于Outlook对象模型，并且可以在后台线程中使用。

a