Zack Barresse
04-27-2006, 10:26 AM
Hey all,
Can anybody tell me why this code fails after the first iteration email??
..
Sub LoopThrough_SentReceived()
Dim OL As Outlook.Application
Dim NS As Outlook.NameSpace, Inbox As Outlook.MAPIFolder, FL As Outlook.MAPIFolder
Dim Email As Object, IBitems As Outlook.Items
Dim XL As Outlook.MailItem, XLwb As Object, XLws As Object
Dim Cnt As Long
On Error GoTo ErrHandle
Set OL = ThisOutlookSession
Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
Set IBitems = Inbox.Items
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set XLwb = XL.Workbooks.Add
Set XLws = XLwb.Sheets(1)
Cnt = 1
For Each FL In Inbox.Folders
For Each Email In IBitems
Cnt = Cnt + 1
XLws.Cells(Cnt, 1).Value = Email.ReceivedByName
Next Email
Next FL
ErrHandle:
If Err <> 0 Then
XL.Quit
Else
MsgBox Cnt
End If
Set Inbox = Nothing
Set NS = Nothing
Set XLws = Nothing
Set XLwb = Nothing
Set XL = Nothing
End Sub
Can anybody tell me why this code fails after the first iteration email??
..
Sub LoopThrough_SentReceived()
Dim OL As Outlook.Application
Dim NS As Outlook.NameSpace, Inbox As Outlook.MAPIFolder, FL As Outlook.MAPIFolder
Dim Email As Object, IBitems As Outlook.Items
Dim XL As Outlook.MailItem, XLwb As Object, XLws As Object
Dim Cnt As Long
On Error GoTo ErrHandle
Set OL = ThisOutlookSession
Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
Set IBitems = Inbox.Items
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set XLwb = XL.Workbooks.Add
Set XLws = XLwb.Sheets(1)
Cnt = 1
For Each FL In Inbox.Folders
For Each Email In IBitems
Cnt = Cnt + 1
XLws.Cells(Cnt, 1).Value = Email.ReceivedByName
Next Email
Next FL
ErrHandle:
If Err <> 0 Then
XL.Quit
Else
MsgBox Cnt
End If
Set Inbox = Nothing
Set NS = Nothing
Set XLws = Nothing
Set XLwb = Nothing
Set XL = Nothing
End Sub