Outlook Code Problem On Email Moves - Error -2147221233

[ejek6337]

Please review the following code that moves emails between different outlook
box folders and subsequently creates an excel spreadsheet. This code has
always worked, but for some reason it started not working on a few people's
computers. It still works on mine however. They have the same references as
me loaded, namely the VBA, Outlook 11, Office 11, and OLE Automation
references. Here is the code:

' Create session so that security prompt is not displayed in outlook
Set olapp = Application
Set Session = olapp.Session
Set AL = olapp.Session.AddressLists("Global Address List")
Set fld =
olapp.GetNamespace("Mapi").GetFolderFromID("000000000F7EA95D623B0B4191BB263A85023FAC010079A7F373FA835448AE050AECC8235EE1000000E0C1070000")
Set fldSB =
olapp.GetNamespace("Mapi").GetFolderFromID("000000001A447390AA6611CD9BC800AA002FC45A0300B72F7F36FCD61A408C03CA765846D34D0000006EADB40000")
Set fldMoveTemp =
olapp.GetNamespace("Mapi").GetFolderFromID("000000000F7EA95D623B0B4191BB263A85023FAC01007953D6860919C04DB07FDB35A24059AA0000059D53060000")
Set fldMoveFinal =
olapp.GetNamespace("Mapi").GetFolderFromID("000000000F7EA95D623B0B4191BB263A85023FAC01007953D6860919C04DB07FDB35A24059AA0000059D53070000")

If Not fld Is Nothing Then

'a) count the mail items in the folder
intTotalItems = fld.Items.Count
ErrorCount = 0

'3) set the location of the storage file and
' create the Excel worksheet
Dim objWkb As Object 'Excel.Workbook
Dim objWks As Object 'Excel.Worksheet
Dim objExcel As Object 'Excel.Application
Dim i As Integer, j As Integer

'Set objExcel = New Excel.Application
Set objExcel = CreateObject("Excel.Application")
Set objWkb = objExcel.Workbooks.Add
Set objWks = objExcel.ActiveSheet

objWks.Cells(1, 1).Value = "Subject"
objWks.Cells(1, 2).Value = "Received"
objWks.Cells(1, 3).Value = "Sender Name"
objWks.Cells(1, 4).Value = "EMAIL"
objWks.Cells(1, 5).Value = "Body"
objWks.Cells(1, 6).Value = "Notes"

'4) Loop through all emails in the Rome CSBASES Outlook folder and move
them into the Archive Temp Folder
SubRoutine = "CSBASES"
i = fld.Items.Count
Do While (i - ErrorCount) > 0
For Each itm In fld.Items
DoEvents
If itm.Class = olMail Then
itm.Move (fldMoveTemp) ' Problem occurring here in
some cases with error -2147221233 Automation Error
End If
Next_CSBASES:
Next itm
i = fld.Items.Count
Loop

 

[Dmitry Streblechenko]

The error is MAPI_E_NOT_FOUND
You are modifying the collection in the "for each" loop.
Use

for i = Items.Coiunt to 1 Step -1

loop instead

--
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
-

 

[ejek6337]

I gave it a try on mine and it worked. I just need to try it on the other
personnels' computers and will let you know. Thanks.

Ed