Question

我使用以下代码存档已标记为已完成的电子邮件。它应该检查我们共享文件夹中的所有电子邮件，以查看今天之前标记为已完成的任何内容。它可以工作，但我必须多次运行代码来存档所有受影响的引用。有没有人有任何想法如何让它一次性工作？

Public Const CEpath As String = "\\s-estimating\CentralEstimating\"

Option Explicit
Public Const sArchivePath As String = Miscellaneous.CEpath + "Archives\"

Public Sub ArchiveInbox()
  Dim dtDateToMove As Date
  Dim iMessageCount As Integer
  Dim oDestination As MAPIFolder
  Dim oFileName As String
  Dim oNamespace As NameSpace
  Dim oMailItem As MailItem
  Dim oProgress As New ProgressDialogue
  Dim oSource As MAPIFolder
  Dim oStore As Store
  Dim oOSPsource As MAPIFolder
  'Dim oOSPDestination As MAPIFolder

  On Error GoTo HandleError

  ' Obtain a NameSpace object reference.
  Set oNamespace = Application.GetNamespace("MAPI")
  Set oStore = oNamespace.Stores.item("Rings")
  Set oSource = oStore.GetDefaultFolder(olFolderInbox)

  ' try to connect to the OSP Folder
  On Error Resume Next
  'Debug.Print oSource.Folders("OSP Quotes").Items.count
  Set oOSPsource = oSource.Folders("OSP Quotes")
  On Error GoTo HandleError

  ' Start Progess form
  oProgress.Configure title:="Archive Old RFQs", _
                      status:="Please stand by while the operation is being processed…", _
                      Min:=0, _
                      Max:=CDbl(oSource.Items.count), _
                      optShowTimeElapsed:=True, _
                      optShowTimeRemaining:=True
  oProgress.Show vbModeless

  ' Open Archive (or create and open)
  dtDateToMove = PreviousBusinessDay(Date)
  If Month(PreviousBusinessDay(Date)) < 7 Then
    oFileName = "RFQs " & Year(dtDateToMove) & " - Jan-Jun"
  Else
    oFileName = "RFQs " & Year(dtDateToMove) & " - Jul-Dec"
  End If
'  Debug.Print dtDateToMove
'  Debug.Print oFileName
  oNamespace.AddStoreEx Store:=sArchivePath & oFileName & ".pst", _
                        Type:=olStoreUnicode
  Set oDestination = oNamespace.Folders.GetLast
  If Not oDestination.Name = oFileName Then oDestination.Name = oFileName

  ' Sort through all closed emails in Rings and move them to the archive folder
  For Each oMailItem In oSource.Items
    iMessageCount = iMessageCount + 1
    If oProgress.cancelIsPressed Then Exit For
'    Debug.Print "   " & oMailItem.TaskCompletedDate

    If oMailItem.FlagStatus = olFlagComplete Then
      If oMailItem.IsConflict Then
        Err.Raise Number:=95, _
                  Description:="Mail Item Conflict Detected"
      End If
      If oMailItem.TaskCompletedDate <= dtDateToMove Then
        oMailItem.Move oDestination
'        Debug.Print "      Moved"
      End If
    End If
    oProgress.SetValue iMessageCount
  Next oMailItem

ExitRoutine:
  oProgress.Hide

  If oOSPsource Is Nothing Then
    Debug.Print "OSP Quotes folder was not found."
  Else
    If oOSPsource.Items.count > 0 Then
      MsgBox "There are items in OSP Quotes.", vbInformation + vbOKOnly
    End If
  End If

  ' close the store
  oNamespace.RemoveStore oDestination

  Set oProgress = Nothing
  Set oDestination = Nothing
'  Set oOSPDestination = Nothing
  Set oOSPsource = Nothing
  Set oSource = Nothing
  Set oStore = Nothing
  Set oNamespace = Nothing
  Exit Sub

HandleError:
  Debug.Print Err.Number
  Debug.Print Err.Description
  Select Case Err.Number
    Case 95
      MsgBox Prompt:=oMailItem.Subject & vbCrLf & vbCrLf & "An email with the above subject line is in conflict." & _
                 vbCrLf & "You will need to resolve the conflict and run Export to Excel again.", _
         Buttons:=vbCritical + vbOKOnly, _
         title:="Conflict Resolution Required"
      oProgress.Hide
      GoTo ExitRoutine
    Case Else
      If Not ErrorHandling.ErrorLog(Err.Number, Err.Description, "Archive The Inbox") Then
        Err.Clear
        Resume
      End If
  End Select
End Sub

Answer 1

不要对每个＆＃34;使用＆＃34;如果要修改集合，则循环

更改循环

For Each oMailItem In oSource.Items

向下＆＃34;为＆＃34;循环：

dim oItems = oSource.Items
for I = oItems.Count to 1 step -1
  set oMailItem  = oItems.Item(I)

对于每个循环：如何调整代码以在一次运行中而不是多次运行文件

1 个答案: