E
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
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