완료 될 때까지 응답하지 않는 매크로에 대한 상태 업데이트 제공
-
09-12-2019 - |
문제
이메일 아카이브를 검색 할 VBA 매크로가 있습니다.
수만 명의 이메일을 검색 할 때 (또는 내 테스트 시스템에서 몇 백만 걸림) 몇 초 동안 상태를 표시 한 다음 응답하지 않는 상태로 들어간 반면 이메일을 실행하면서
이것은 참을성이없는 사용자가 작업을 조기에 닫을 수 있으며 상태 업데이트를 제공 하여이 문제를 해결하고 싶습니다.
나는 다음 해결책을 코딩했으며, 문제가 루프 동안 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
. 해결책
라인 변경
UserForm1.Repaint
~
DoEvents
예이 작업이 실행 시간이 증가하지만 수천 개의 전자 메일이있는 경우 옵션이별로 없습니다.
팁 : 또한 를 변경하고 싶을 수도 있습니다.
StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."
~
StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."
또한 사용자에게 시간이 걸릴 수있는 프로세스의 시작 부분에 사용자에게 알리는 것이 좋습니다. 따라서 해당 PC에서 작업하지 않으려는 경우 프로세스를 실행할 수 있습니까?
이와 같은 것
.
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