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("000000 000F7EA95D623B0B4191BB263A85023FAC010079A7F373FA83 5448AE050AECC8235EE1000000E0C1070000")
Set fldSB =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 001A447390AA6611CD9BC800AA002FC45A0300B72F7F36FCD6 1A408C03CA765846D34D0000006EADB40000")
Set fldMoveTemp =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53060000")
Set fldMoveFinal =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53070000")

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" (donotspam) wrote in message
...
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("000000 000F7EA95D623B0B4191BB263A85023FAC010079A7F373FA83 5448AE050AECC8235EE1000000E0C1070000")
Set fldSB =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 001A447390AA6611CD9BC800AA002FC45A0300B72F7F36FCD6 1A408C03CA765846D34D0000006EADB40000")
Set fldMoveTemp =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53060000")
Set fldMoveFinal =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53070000")

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

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

"Dmitry Streblechenko" wrote:

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" (donotspam) wrote in message
...
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("000000 000F7EA95D623B0B4191BB263A85023FAC010079A7F373FA83 5448AE050AECC8235EE1000000E0C1070000")
Set fldSB =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 001A447390AA6611CD9BC800AA002FC45A0300B72F7F36FCD6 1A408C03CA765846D34D0000006EADB40000")
Set fldMoveTemp =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53060000")
Set fldMoveFinal =
olapp.GetNamespace("Mapi").GetFolderFromID("000000 000F7EA95D623B0B4191BB263A85023FAC01007953D6860919 C04DB07FDB35A24059AA0000059D53070000")

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