Workaround for Item Count > 500

[Henry Stockbridge]

Hi,

I looked at a few posts in this group to see how I can solve the 500
message limit set in Exchange. I have set variables to NOTHING inside
the loop, and I am still only able to obtain 500 file names. Any
thoughts about working around this limitation? Here is my code:

Sub HarvestReportList_2()

Const DBLocation = "\\---\----\"
Const DBName = "--------.mdb"

On Error GoTo PROC_ERR

On Error Resume Next

Dim myOlApp As Outlook.Application
Dim myExplorer As Outlook.Explorer
Dim objSelected As Outlook.Selection
Dim myItem As Object
Dim myAttach As Outlook.Attachment

Dim accApp As Access.Application
Dim db As Database
Dim rst As Recordset

Dim SentOn As Date
Dim Subject As String
Dim DisplayName As String
Dim FileName As String
Dim DayofWeek As String
Dim WeekNo As String
Dim ReportDescription As String
Dim Date_2 As String

Set myOlApp = CreateObject("Outlook.Application")
Set myExplorer = myOlApp.ActiveExplorer
Set objSelected = myExplorer.Selection

Set accApp = CreateObject("Access.Application")
Access.OpenCurrentDatabase DBLocation & DBName
Set db = CurrentDb
Set rst = db.OpenRecordset("tblEmailMessages_Reports")

If objSelected.Count <> 0 Then
MsgBox objSelected.Count
For Each myItem In objSelected
If myItem.Class = olMail Then
SentOn = myItem.SentOn
Subject = myItem.Subject
DisplayName = myItem.To
Subject = myItem.Subject
DayofWeek = Format(SentOn, "dddd")
ReportDescription = Trim(Mid(Subject, 11, (InStr(1,
Subject, "(") - 11)))
Date_2 = Format(myItem.SentOn, "yyyymmdd")

If myItem.Attachments.Count = 0 Then
rst.AddNew
rst!SentOn = SentOn
rst!Subject = Subject
rst!DisplayName = DisplayName
rst!DayofWeek = DayofWeek
rst!WeekNo = Format(SentOn, "ww")
rst!Date = Format(SentOn, "Short Date")
rst!ReportDescription = ReportDescription
rst!Date2 = Date_2
rst.Update
ElseIf myItem.Attachments.Count > 0 Then
For i = 1 To myItem.Attachments.Count
Set myAttach = myItem.Attachments(i)
AttachName = myAttach.FileName
DoEvents
rst.AddNew
rst!SentOn = SentOn
rst!Subject = Subject
rst!DisplayName = DisplayName
rst!DayofWeek = DayofWeek
rst!WeekNo = Format(SentOn, "ww")
rst!Date = Format(SentOn, "Short Date")
rst!ReportDescription = ReportDescription
rst!FileName = AttachName
rst!Date2 = Date_2
rst.Update
Set myAttach = Nothing
Next
End If
End If
Set myItem = Nothing
Set objSelected = Nothing
Next
End If

db.Close

Set accApp = Nothing
Set db = Nothing
Set rst = Nothing

Set myOlApp = Nothing
Set myExplorer = Nothing
Set myFolder = Nothing
Set objSelected = Nothing

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox "Error " & Err.Number & " " & Err.Description
Resume PROC_EXIT

End Sub