Предоставление обновлений состояния для макроса, который переходит в состояние без ответа до завершения - PullRequest
Новая
       11

Предоставление обновлений состояния для макроса, который переходит в состояние без ответа до завершения

3 голосов
/ 08 марта 2012

У меня есть макрос VBA для поиска в почтовых архивах.

При поиске по десяткам тысяч писем (или даже нескольким сотням на моей тестовой машине) он отображает состояние в течение нескольких секундзатем переходит в состояние «Не отвечает» при работе с остальными электронными письмами.

Это привело к тому, что нетерпеливые пользователи преждевременно закрыли задачу, и я хотел бы исправить это, предоставив обновления статуса.1006 * Я кодировал следующее решение и считаю, что проблема заключается в способе работы GarbageCollector в VBA во время цикла. 

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

1 Ответ

7 голосов
/ 09 марта 2012

Измените строку

UserForm1.Repaint

на

DoEvents

Да, это увеличит время выполнения, но в случае тысячэлектронных писем, тогда у вас не так много вариантов.

СОВЕТ: Также вы можете изменить

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

на

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

Также желательно проинформировать вашего пользователя в начале процесса, что это может занять некоторое время, и, следовательно, они могут запустить процесс, когда уверены, что не хотят работатьна этом компьютере?

Как-то так 

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

...