توفير تحديثات الحالة للماكرو الذي يدخل في حالة عدم الاستجابة حتى الانتهاء
-
09-12-2019 - |
سؤال
لدي VBA Macro للبحث في أرشيفات البريد الإلكتروني.
عند البحث في عشرات الآلاف من رسائل البريد الإلكتروني (أو حتى بضع مئات فقط على جهاز الاختبار الخاص بي)، فإنه يعرض الحالة لبضع ثوانٍ، ثم يدخل في حالة عدم الاستجابة أثناء تصفح بقية رسائل البريد الإلكتروني.
وقد أدى هذا إلى إغلاق المستخدمين غير الصبر للمهمة قبل الأوان، وأود تصحيح ذلك من خلال توفير تحديثات الحالة.
لقد قمت بترميز الحل التالي، وأعتقد أن المشكلة تكمن في الطريقة التي يعمل بها 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
المحلول
تغيير الخط
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
هث
سيد