Fournir des mises à jour d'état pour les macros qui ne répondent pas jusqu'à la fin

Question

J'ai une macro VBA pour rechercher dans les archives de courrier électronique.

Lors d'une recherche dans des dizaines de milliers d'e-mails (ou même seulement quelques centaines sur ma machine de test), il affiche l'état pendant quelques secondes, puis entre dans un état de non-réponse tout en parcourant le reste des e-mails.

Cela a conduit des utilisateurs impatients à abandonner la tâche prématurément, et j'aimerais remédier à ce problème en fournissant des mises à jour de statut.

J'ai codé la solution suivante et je pense que le problème réside dans la façon dont GarbageCollector fonctionne dans VBA pendant la boucle.

Public Sub searchAndMove()

    UserForm1.Show

    ' Send a message to the user indicating
    ' the program has completed successfully, 
    ' and displaying the number of messages sent during the run.

End Sub

Private Sub UserForm_Activate()

Me.Width = 240
Me.Height = 60

Me.Label1.Width = 230
Me.Label1.Height = 50

Dim oSelectTarget As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
Dim oSearchCriteria As String

' Select the target folder to search and then the folder to
' which the files should be moved
Set oSelectTarget = Application.Session.PickFolder
Set oMoveTarget = Application.Session.PickFolder

oSearchCriteria = InputBox("Input search string: ")

Dim selectedItems As Outlook.Items
Set selectedItems = oSelectTarget.Items
Dim selectedEmail As Outlook.MailItem

Dim StatusBarMsg As String
StatusBarMsg = ""

Dim initialCount As Long
initialCount = selectedItems.count


Dim movedCounter As Long
movedCounter = 0
Dim x As Long
Dim exists As Long

' Function Loop, stepping backwards
' to prevent errors derived from modifying the collection
For x = selectedItems.count To 1 Step -1
    Set selectedEmail = selectedItems.Item(x)
    ' Test to determine if the subject contains the search string

    exists = InStr(selectedEmail.Subject, oSearchCriteria)
    If Len(selectedEmail.Subject) > 999 Then
        selectedEmail.Move oMoveTarget
    Else:
        If exists <> 0 Then
            selectedEmail.Move oMoveTarget
            movedCounter = (movedCounter + 1)
        Else: End If
    End If
    Set selectedEmail = Nothing
    StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."

    UserForm1.Label1.Caption = StatusBarMsg
    UserForm1.Repaint
Next x

Dim Msg As String
Dim Response
Msg = "SearchAndMove has detected and moved " & movedCounter & _
  " messages since last run."
Response = MsgBox(Msg, vbOKOnly)


' Close the References to prevent a reference leak
Set oSelectTarget = Nothing
Set oMoveTarget = Nothing
Set selectedItems = Nothing
Set selectedEmail = Nothing

Unload Me

End Sub

Answer 1

Changer la ligne

UserForm1.Repaint

à

DoEvents

Oui, cela augmentera le temps d'exécution, mais s'il y a des milliers d'e-mails, vous n'avez pas beaucoup d'option.

CONSEIL: Aussi, vous voudrez peut-être changer

StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."

à

StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."

Il est également conseillé d'informer votre utilisateur au début du processus que cela peut prendre du temps et qu'il peut donc exécuter le processus lorsqu'il est sûr de ne pas vouloir travailler sur ce PC ?

Quelque chose comme ça

Sub Sample()
    Dim strWarning As String
    Dim Ret

    strWarning = "This process may take sometime. It is advisable to run this " & _
    "when you don't intend to use the pc for sometime. Would you like to Continue?"

    Ret = MsgBox(strWarning, vbYesNo, "Information")

    If Ret <> vbYes Then Exit Sub

    For x = SelectedItems.Count To 1 Step -1

    '~~> Rest of the code
End Sub

HTH

Sidé