对于每个循环:如何调整代码以一次运行而不是多次运行来移动文件 [英] For Each loop: How to adjust code to move files in one run rather than multiple

问题描述

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

I am using the below code to archive emails that have been marked completed. It is supposed to check all emails in our shared folder for anything marked complete prior to today's date. It works, but I must run the code multiple times to archive all of the affected quoted. Does anyone have any ideas how to get this to work in one shot?

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

推荐答案

如果要修改集合，请不要使用"for each"循环

Do not use "for each" loop if you are modifying the collection

更改循环

For Each oMailItem In oSource.Items

进入向下的"for"循环:

to a down "for" loop:

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

这篇关于对于每个循环:如何调整代码以一次运行而不是多次运行来移动文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！