Outlook 2010 Macro throws VBA error 'For loop not initialized' - vba

I got this bit of code from someone's blog years ago. It basically iterates through all the Outlook mail rules, and executes them (handy to organize your inbox!). I've recently upgrade to Outlook 2010 from 2007. Now I get a very strange error stating
Run-time error '92':
For loop not initialized
However, while debugging this, it will always run through 8 times (out of 20-25), then it throw this error.
Here is the offending code:
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
'get default store (where rules live) & get rules
Set st = Application.Session.DefaultStore
Set myRules = st.GetRules
'iterate all the rules
For Each rl In myRules
If rl.RuleType = olRuleReceive Then 'determine if it’s an Inbox rule, 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
Edit:
Per Jay Riggs's comment, clearing the entire for block still results in the error.

I'd replace this loop with something like:
Dim k as Long
For k = 1 To myRules.Count ' might be 0-based, didnt check
set rl = myRules(k)
If rl.RuleType = olRuleReceive Then 'determine if it’s an Inbox rule, if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
I bet there is some rule at position 8 or 9 that doesn't fit into the myRules collection and that throws the error. You can also check the myRules collection at the offending point. Maybe Office 2007 was more forgiving and skipped that entry.

So the issue ended up being that some of the rules referred to a PST file I missed on moving to my new machine. Thanks to Justin for forcing me to take a deeper look at the rules!
+1 to the obscure error message for this.

Related

How to verify a mail from today exist?

I want to see if an email exists in a particular Outlook folder, using Excel VBA.
Sub Get_Calls_MTD_Data()
'making sure windows not jumping forth and back
Application.ScreenUpdating = False
Dim getCalls As Workbook
Dim releaseCalls As Workbook
Dim fPat As String
fPat = ThisWorkbook.Path
Dim SNDate As String
'The sheetname gets the date for the day name, so using variable for that
SNDate = Date
'-------------------
'Error handling doesn't work
'this dosent work any longer?
'If Dir(fPat & "\Outlookdata\calls mtd\" & Date & "." & "***") = "" Then
'
' MsgBox "does not find mail"
'
'Else
' making sure the windows dosen jump forth and back and no alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---------------------------
Set getCalls = Workbooks.Open(fPat & "\Outlookdata\Calls mtd\" & Date & "." & "*")
Set releaseCalls = Workbooks.Open(fPat & "\" & ThisWorkbook.Name)
getCalls.Activate
If Not IsEmpty(Range("G2").Value) = True Then
'finding last row
mylastagent = getCalls.Sheets(SNDate).Cells(Rows.Count, "G").End(xlUp).Row
getCalls.Sheets(SNDate).Range("G2:H" & mylastagent).Copy
releaseCalls.Activate
releaseCalls.Sheets("calls").Range("A1").PasteSpecial xlPasteValues
End If
getCalls.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("M3").Select
Update_Day_When_Calls_Updates
'Just the end if for the faulty error handling in the top
' End If
End Sub
Do I have to loop through the folder to find an email from today?
Also I started to get the prompt "clipboard has too much information, do you want to save it" in the end. Tried here for instance:
Disable clipboard prompt in Excel VBA on workbook close
Don't use strict date checks in Outlook. Instead, you need to use the Find/FindNext or Restrict methods of the Items class that allows getting only items that correspond to the search criteria. In the search criteria I'd recommend using less or greater conditions for dates.
Outlook evaluates date-time values according to the time format, short date format, and long date format settings in the Regional and Language Options applet in the Windows Control Panel. In particular, Outlook evaluates time according to that specified time format without seconds. If you specify seconds in the date-time comparison string, the filter will not operate as expected.
Although dates and times are typically stored with a date format, filters using the Jet and DAV Searching and Locating (DASL) syntax require that the date-time value to be converted to a string representation. In Jet syntax, the date-time comparison string should be enclosed in either double quotes or single quotes. In DASL syntax, the date-time comparison string should be enclosed in single quotes.
To make sure that the date-time comparison string is formatted as Microsoft Outlook expects, use the Visual Basic for Applications Format function (or its equivalent in your programming language).
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.
Read more about the Find/FindNext and Restrict methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
If you need to search for items in multiple folders you may consider using the AdvancedSearch method of the Application class, see Advanced search in Outlook programmatically: C#, VB.NET.
In the case of "today's mail", if processing time is noticeable, you can .Sort then stop processing once older mail is found.
Option Explicit
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
' Where code is not in Outlook
' Reference Microsoft Outlook nn.n Object Library
Dim ol As Outlook.Application
Dim fol As Outlook.Folder
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set fol = Session.Folders("Random#Email.com")
Set fol = fol.Folders("OutlookData")
Set fol = fol.Folders("Calls Daily")
Dim folItems As Items
Set folItems = fol.Items
folItems.Sort "[ReceivedTime]", True
Dim j As Long
For j = 1 To folItems.Count
If folItems(j).Class = olMail Then
Set mi = folItems(j)
If mi.Attachments.count > 1 Then
If Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
Debug.Print mi.Subject
Debug.Print " " & Format(mi.ReceivedTime, "yyyy-mm-dd")
Else
'Older mail
Exit For
End If
End If
End If
Next
End Sub
.Restrict and .Find could be applied to all cases.
I managed to do it like this, probably not the best way, no certainly not the best way, but i solved it for my needs :) Thanks Niton.
Public RecivedToday As String
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("Random#Email.com").Folders("OutlookData").Folders("Calls Daily")
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 1 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
'Debug.Print Format(mi.ReceivedTime, "yyyy-mm-dd")
RecivedToday = Format(Date, "yyyy-mm-dd")
'Debug.Print RecivedToday
End If
End If
Next i
End Sub

Run rule from VBA fails

I want to be able to run a rule from a macro/button in ribbon instead of going through all the clicks needed to "Run rules now" manually. Using Outlook 2016.
I have tried to make the most simple VBA script in order to do that. For some reason, my Outlook rule is stored in the second store and not the default store.
When running the macro, the MsgBox is prompted, so the rule is found but it is not executed, and the e-mails in target are not moved as they should.
How can I improve my code in order to actually execute the rule.
Sub RunRule()
Dim rules As Outlook.rules
Set rules = Application.Session.Stores(2).GetRules()
rules.Item("kundeordre").Execute ShowProgress:=True
MsgBox rules.Item("kundeordre")
End Sub
The rules in Outlook:
For rules in a non-default store, specify the folder.
Option Explicit
Sub RunRule()
' https://learn.microsoft.com/en-us/office/vba/api/outlook.rule.execute
Dim olRules As rules
Dim myRule As Rule
Dim myRuleName As String
Dim olStore As Store
Dim olFolder As Folder
Set olStore = Session.Stores(2)
Debug.Print olStore
With olStore
Set olRules = .GetRules()
Set olFolder = .GetDefaultFolder(olFolderInbox)
End With
myRuleName = "kundeordre"
For Each myRule In olRules
Debug.Print "myRule " & myRule
If myRule = myRuleName Then
' Folder required for non-default store
myRule.Execute ShowProgress:=True, Folder:=olFolder
MsgBox myRule & " executed in " & olStore
Exit For
End If
Next
End Sub

Run-time error 430: Class does not support automation or does not support expected interface"* error while looping through mails in Outlook

I am trying to loop through emails in outlook to get the "ConversationTopic" for each mail.
I have written the excel VBA code as below and for some reason it will have this "Run-time error 430: Class does not support automation or does not support expected interface" error. The code is able to loop through around 1000 emails before having this error. It did not error out immediately during the start of the loop. It will stopped at the line:
Debug.Print counter & vbTab & outlook_mail.class & vbTab & outlook_mail.ConversationTopic
If i changed the line as such it would not have any issue looping through the mail
Debug.Print counter & vbTab & outlook_mail.class
OR
Debug.Print counter
The error will only appear if this is added
outlook_mail.ConversationTopic
I've tried to google for a solution I could not find any for this error where the code stopped halfway while running.
Remark: The reason I used latebinding is to ensure all users in my office is able to use the script.
Sub latebinding()
Dim OutlookApp As Object
Set OutlookApp = CreateObject("Outlook.Application")
Dim Outlook_namespace As Object
Set Outlook_namespace = OutlookApp.GetNamespace("MAPI")
Dim Outlook_folder As Object
Set Outlook_folder = Outlook_namespace.GetDefaultFolder(6)
Dim outlook_item As Object
Set outlook_item = Outlook_folder.Items
Dim outlook_mail As Object
Set outlook_mail = OutlookApp.CreateItem(0)
Dim outlook_attachment As Object
Set outlook_attachment = outlook_mail.Attachments
Dim counter As Integer
counter = 1
For Each outlook_mail In outlook_item
If TypeName(outlook_mail) = "MailItem" Then
Debug.Print counter & vbTab & outlook_mail.class & vbTab & outlook_mail.ConversationTopic
End If
counter = counter + 1
Next outlook_mail
Set OutlookApp = Nothing
Set Outlook_namespace = Nothing
Set outlook_attachment = Nothing
Set Outlook_folder = Nothing
Set outlook_item = Nothing
Set outlook_mail = Nothing
End Sub
You may be running into the limitation mentioned in the following article
https://learn.microsoft.com/en-us/windows-hardware/drivers/ddi/wdm/nf-wdm-dbgprint#:~:text=There%20is%20no%20upper%20limit,transmit%20512%20bytes%20of%20information.
that: "any single call to DbgPrint will only transmit 512 bytes of information. There is also a limit to the size of the DbgPrint buffer. See DbgPrint Buffer and the Debugger for details."

Providing status updates for macro that goes into not responding state until completion

I have a VBA Macro to search through email archives.
When searching through tens of thousands of emails, (or even just a couple hundred on my test machine) it displays the status for a few seconds, then enters a Not Responding state while running through the rest of the emails.
This has led impatient users to close out of the task prematurely, and I would like to rectify this by providing status updates.
I have coded the following solution, and believe that the problem lies in the way the GarbageCollector functions in VBA during the Loop.
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
Change the line
UserForm1.Repaint
to
DoEvents
Yes this will increase the execution time but in case there are thousands of emails then you don't have much of an option.
TIP:
Also you might want to change
StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."
to
StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."
Also it is advisable to inform your user at the beginning of the process that it might take time and hence they can run the process when they are sure they do not want to work on that pc?
Something like this
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

Move PST files to server via VB

At work we've picked up a new exchange server, so my boss was going to have me go around to all our computers and manually move all the open PST files people had to their folder on the new server. I, for obvious reasons, decided that it would be simpler to script this. After a bit of research I came across one such script that only needed a bit of tweaking (found here http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/) but had a lot of other things I wouldn't really need (checks for if it was running on a laptop, only affecting local folders, etc.), so I cannibalized the main logic out of it into my own version without most of these sanity checks. The problem I'm running into is that I have 2 seemingly identical loops iterating a different number of times, and it causes problems. Here's what I have
Option Explicit
Const OverwriteExisting = True
' get username, will use later
Dim WshNetwork: Set WshNetwork = wscript.CreateObject("WScript.Network")
Dim user: user = LCase(WshNetwork.UserName)
Set WshNetwork = Nothing
' network path to write pst files to
Dim strNetworkPath : strNetworkPath = "\\server\folder\"
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\" End If
' initiate variables and instantiate objects
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFiles, pstName, strPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("c:\My\Desktop\pst_script_log.txt " , True)
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Dim count : count = -1
' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
pstFiles = GetPSTPath(objFolder.StoreID)
pstName = objFolder.Name
count = count + 1
objTextFile.Write(count & " " & pstFiles & vbCrLf)
ReDim Preserve arrNames(count)
arrNames(count) = pstName
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
objOutlook.Session.RemoveStore objFolder
End IF
Next
' closes the outlook session
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
' quits if no pst files were found
If count < 0 Then
wscript.echo "No PST Files Found."
wscript.Quit
End If
objTextFile.Write("moving them" & vbCrLf)
' moves the found pst files to the new location
Dim pstPath
For Each pstPath In arrPaths
On Error Resume Next
objTextFile.Write(pstPath & vbCrLf)
objFSO.MoveFile pstPath, strNetworkPath
If Err.Number <> 0 Then
wscript.sleep 5000
objFSO.MoveFile pstPath, strNetworkPath
End If
Err.Clear
On Error GoTo 0
Next
Set objFSO = Nothing
' sleep shouldn't be necessary, but was having issues believed to be related to latency
wscript.sleep 5000
'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Re-map Outlook folders
For Each pstPath In arrPaths
objTextFile.Write("Remapping " & pstPath & " to " & strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1) & vbCrLf)
objNS.AddStore strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1)
Next
count = -1
For Each objFolder In objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
count = count + 1
objTextFile.Write("Renaming " & GetPSTPath(objFolder.StoreID) & " to " & arrNames(count) & vbCrLf)
objFolder.Name = arrNames(count)
End If
Next
objOutlook.Session.Logoff
objOutlook.Quit
objTextFile.Write("Closing Outlook instance and unmapping obj references...")
Set objFolder = Nothing
Set objTextFile = Nothing
Set objOutlook = Nothing
Set objNS = Nothing
wscript.echo "Done."
wscript.Quit
Private Function GetPSTPath(byVal input)
'Will return the path of all PST files
' Took Function from: http://www.vistax64.com/vb-script/
Dim i, strSubString, strPath
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then
strPath = strPath & ChrW("&H" & strSubString)
End If
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
The offending loop is at lines 24 and 81. The specific error is that count gets incremented more in the second loop than the first, however that's because the first loop is coming up short on its iterations and missing the last PST file. People with similar issues on the site where I found most of this code said that adding in wscript.sleep functions in certain spots helped them, but I've had no such luck in their recommended spots, and I get the impression that their issues are not the same as mine.
I'd greatly appreciate help with what's going wrong in my code, and I'm open to suggestions for ways to correct other issues I don't see, and think there's a better way to do something like this.
EDI:After doing some more research on my issue, it seems that by performing RemoveStore inside the loop at line 24 I'm changing the value of objNS.Folders (which makes sense), and to avoid this I should store the objFolder items I need to remove and do so in another loop. Problem now is that I don't know how to do that, I've tried
[line 35]
ReDim Preserve arrFolders(count)
arrFolders(count) = objFolder
End If
Next
For Each objFolder in arrFolders
objOutlook.Session.RemoveStore objFolder
Next
However I get Type Mismatch errors regarding RemoveStore, so I think it isn't storing the object how it needs to. Any ideas?
FWIW - attaching to PSTs on a network is not supported. See http://support.microsoft.com/kb/297019/en-us and http://blogs.technet.com/b/askperf/archive/2007/01/21/network-stored-pst-files-don-t-do-it.aspx
So, Finally got this working right (or close enough to right). As was mentioned in the comments from Brad, you should search your disk for PST files as well as what I have here. This method ONLY affects PST files that the user has open in Outlook, and NOT all PST files on their computer. What was happening was as I mentioned in my Edit, objOutlook.Session.RemoveStore was changing the value of objNS.Folders, which would break my first For loop. You need to do this outside of your enumartion loop, otherwise it breaks and misses some (as well as mislabels some when remapping them). Also, outside of that loop objFolder needed to be redefined as a MAPIFolder object, or else you get the Type Mismatch errors when trying to remove Working sample is:
' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
count = count + 1
pstFiles = GetPSTPath(objFolder.StoreID)
pstName = objFolder.Name
pstFolder = objFolder
objTextFile.Write(count & " " & pstFiles & vbCrLf)
ReDim Preserve arrNames(count)
arrNames(count) = pstName
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
'objOutlook.Session.RemoveStore objFolder
End If
Next
For Each pstName in arrNames
set objFolder = objNS.Folders.Item(pstName)
objNS.RemoveStore objFolder
Next
set objFolder = Nothing