Outlook Code Problem On Email Moves - Error -2147221233

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

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" <ejek6337 DeleteThis @yahoo.com(donotspam)> wrote in message
news:57771D77-D794-406A-9A8C-A8369C2B1693@microsoft.com...
> 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