Can someone help me with following code to increase/faster outlook VBA Macro Speed ?

[nbm1515]

Hi

Can someone help me with following code to increase/faster outlook VBA Macro Speed ? Currently It taking lot of time run all email rules and getting process slow.




Sub RunAllInboxRules()
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
'On Error Resume Next

' get default store (where rules live)
Set st = Application.Session.DefaultStore
' get rules
Set myRules = st.GetRules

' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next

' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"

Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub

[Logit]

.
See if this improves things :



Sub RunAllInboxRules()
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
'On Error Resume Next


With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With


' get default store (where rules live)
Set st = Application.Session.DefaultStore
' get rules
Set myRules = st.GetRules


' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next


With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With


' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"


Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub

[nbm1515]

Thanks for your reply,

But I am getting debug/ run error while execution of above code at start of .ScreenUpdating

I am using this VBA code for outlook rule email or such booster can use with Excel spread sheet VBA macro ?

[Paul_Hossler]

.
See if this improves things :


That looks like Excel. Probably won't work in Outlook

[Paul_Hossler]

If you delete these lines, is it better?



rl.Execute ShowProgress:=True
count = count + 1


Or make ShowProgress := False