Solved

"Item not found in this collection" instantiating class that imports email sender's addresses from Outlook

Posted on 2001-07-11
5
300 Views
Last Modified: 2012-06-27
OK, this is a tricky one...

I wrote an Access2000 form which recursively extracts email addresses from emails in Outlook2000 into an Access table.  I ran this last year and it worked great.  Since then I have moved everything to another computer and I can't get the damn thing to work!!!

The database (69k zipped) is available for download at
http://www.ecoms.com/ftp/mailxtract.zip

I have a button on a form called frmImportEmailAddresses which calls the following code

Dim clsOE As clsMMOutlook
Set clsOE = New clsMMOutlook

and I get "error #3265 Item not found in this collection" with a breakpoint on the second line (Set clsOE = New clsMMOutlook)

I can only assume that the error has something to do with the Class_Initialize() in clsMMOutlook

I will list the code of clsMMOutlook (and frmImportEmailAddresses) below, but first let me say I have the following references.

visual Basic For Applications
Microsoft Access 9.0 Object Library
OLE Automation
Microsoft Outlook 9.0 Object Library
Microsoft DAO 3.6 Object Library

The database does compile.

The code for clsMMOutlook is below.  Any advice is greatly appreciated!!! :-)

--------------------

Option Compare Database
Option Explicit

Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace

Dim MyWS As DAO.Workspace
Dim MyDB As DAO.Database
Dim MyTable As DAO.TableDef
Dim MyRS As DAO.Recordset


Private Sub Class_Initialize()

Set MyWS = DAO.Workspaces(0)
Set MyDB = MyWS.Databases(0)
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI")

End Sub



Public Function ExtractFolderInto(strRootFolder As String, strTableName As String) As Boolean

'extracts email from the selected root folder in outlook
'and uses the tablename to store the extracted email names and addresses

Dim I As Integer, MyFolder As Variant

Set MyTable = MyDB.TableDefs(strTableName)
Set MyRS = MyTable.OpenRecordset(dbOpenTable)

Set MyFolder = myNameSpace.Folders(strRootFolder)

For I = 1 To MyFolder.Folders.Count
    If FolderNameOK(MyFolder.Folders(I).Name) Then ExtractSubFolder (MyFolder.Folders(I))
Next

ExtractFolderInto = True

End Function



Private Function FolderNameOK(strFolderName As String) As Boolean

Dim boolResult As Boolean

boolResult = False

Select Case strFolderName
   
    Case "Calendar"
    Case "Contacts"
    Case "Deleted Items"
    Case "Drafts"
    Case "Faxes"
    Case "Journal"
    Case "Notes"
    Case "Outbox"
    Case "PocketMirror"
    Case "Tasks"
    Case "Sent Items"
       
    Case Else: boolResult = True
   
End Select

FolderNameOK = boolResult

End Function



Private Sub ExtractSubFolder(SubFolder As Variant)

On Error GoTo esferr

Dim I As Integer, J As Integer, K As Integer
Dim myItem As Variant, MyReply As Variant, MyPeople As Variant, MyPerson As Variant, MyAddressEntry As Variant

DoEvents

For I = 1 To SubFolder.Folders.Count
    'no need to check if FolderNameOK since we are at the subfolder level already
    ExtractSubFolder (SubFolder.Folders(I))
Next

For J = 1 To SubFolder.Items.Count
    Set myItem = SubFolder.Items(J)
    If myItem.Class = olMail Then
        Set MyReply = myItem.Reply
        With MyReply
            Set MyPeople = .Recipients
            For K = 1 To MyPeople.Count
                Set MyPerson = MyPeople(K)
                Set MyAddressEntry = MyPerson.AddressEntry
               
                MyRS.AddNew
                MyRS!PersonName = MyPerson.Name
                MyRS!EmailAddress = MyAddressEntry.Address
                MyRS.Update  'duplicate email address will raise primary key error that must be trapped
               
                Set MyPerson = Nothing
            Next

            Set MyPeople = Nothing
        End With
        Set MyReply = Nothing
    End If
    Set myItem = Nothing
Next
               
Exit Sub

esferr:

Select Case Err.Number
    Case 13: 'type mismatch
        'Stop
        Resume Next
    Case 91: 'object variable or with block variable not set
        Resume Next
    Case 424: 'object required
        Resume Next
    Case 3022: 'duplicate index or key (email address)
        Resume Next
    Case 3058: 'index or primary key cant contain a null value
        Resume Next
    Case -2147352567: 'could not send the message
        Resume Next
    Case Else:
        MsgBox "Error in clsMMOutlookExtractor:  " & CStr(Err.Number) & " : " & Err.Description
        Err.Raise Err.Number, "clsMMOutlookExtractor.ExtractSubFolder", Err.Description
        Exit Sub
End Select
               
               
End Sub

Private Sub Class_Terminate()

Set myOlApp = Nothing

MyRS.Close
Set MyRS = Nothing
Set MyTable = Nothing

End Sub

----------------------------
For the sake of completeness, the code behind frmImportEmailAddresses is below
----------------------------

Option Compare Database

Private Sub btnImportEmailAddresses_Click()

If IsNull(Me!txtRootFolder) Or IsNull(Me!txtTableName) Then
    MsgBox "Please make sure you have entered a folder and a table name"
    Exit Sub
End If

Me!txtStarted = Now()

Me.TimerInterval = 2200

Dim clsOE As clsMMOutlook
Set clsOE = New clsMMOutlook

DoCmd.Hourglass True

If clsOE.ExtractFolderInto(Me!txtRootFolder, Me!txtTableName) Then
    DoCmd.Hourglass False
    Me.TimerInterval = 0
    Me!txtElapsed = DateDiff("s", Me!txtStarted, Now())
    MsgBox "Import successful"
Else
    DoCmd.Hourglass False
    Me.TimerInterval = 0
    Me!txtElapsed = DateDiff("s", Me!txtStarted, Now())
    MsgBox "Problem occurred with the import"
End If

Set clsOE = Nothing

End Sub

Private Sub Form_Open(Cancel As Integer)
    DoCmd.Maximize
End Sub

Private Sub Form_Timer()

Me!txtElapsed = DateDiff("s", Me!txtStarted, Now())
Me!txtElapsed.Requery
DoEvents

End Sub







0
Comment
Question by:mmerlin
5 Comments
 
LVL 6

Expert Comment

by:simonbennett
ID: 6276353
Hi

Just a thought - how about replacing

Set MyWS = DAO.Workspaces(0)
Set MyDB = MyWS.Databases(0)

with

Set MyDB = CurrentDB()

<still looking at it>...

HTH

Simon
0
 
LVL 6

Expert Comment

by:simonbennett
ID: 6276354
..sorry, that's in class_initialise...
0
 
LVL 5

Accepted Solution

by:
KMAN earned 300 total points
ID: 6277375
Changes made to get it to work:

Was:
Dim clsOE As clsMMOutlook
Set clsOE = New clsMMOutlook

Now:
Dim clsOE As New clsMMOutlook
----------------------------------------
Now:
Private Sub Class_Initialize()
On Error GoTo error
'Set MyWS = DAO.Workspaces(0)
'Set MyDB = MyWS.Databases(0)
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")

finish:
Exit Sub

error:
MsgBox Err.Number & " - " & Err.Description
Resume finish

End Sub
-------------------------------------------
Now:
Public Function ExtractFolderInto(strRootFolder As String, strTableName As String) As Boolean

'extracts email from the selected root folder in outlook
'and uses the tablename to store the extracted email names and addresses

Dim I As Integer, MyFolder As Variant, Found As Boolean

'Set MyTable = CurrentDb.TableDefs(strTableName)
Set MyRS = CurrentDb.OpenRecordset(strTableName)         'dbOpenTable)
Set MyFolder = myNameSpace.Folders.GetFirst
Do Until Found = True
    If MyFolder = strRootFolder Then
        Found = True
        Exit Do
    End If
    Set MyFolder = myNameSpace.Folders.GetNext
Loop
'myNameSpace = myOlApp.GetNamespace("Mapi")
For I = 1 To MyFolder.Folders.Count
    If FolderNameOK(MyFolder.Folders(I).Name) Then ExtractSubFolder (MyFolder.Folders(I))
Next

ExtractFolderInto = True

End Function
---------------------------------------------
HTH, K

0
 
LVL 6

Expert Comment

by:PsychoDazey
ID: 6282457
I use this rather than CreateObject
Dim myOl As Outlook.Application
Set myOl = New Outlook.Application
Do you have any links to Outlook in your DB (such as an address book or folder)?  If so, You have to re-set those links for each PC you add it to.
0
 
LVL 1

Author Comment

by:mmerlin
ID: 6283128
Thanks a lot KMAN!  I guess I was too close to the problem to get it to work... at least it didn't need too many changes.  It all works well now, thank you.  
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

It took me quite some time to sort out all the different properties of combo and list boxes available from Visual Basic at run-time. Not that the documentation is lacking: the help pages are quite thorough and well written. The problem was rather wh…
Introduction When developing Access applications, often we need to know whether an object exists.  This article presents a quick and reliable routine to determine if an object exists without that object being opened. If you wanted to inspect/ite…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now