Solved

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

Posted on 2001-07-11
5
319 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

Three Reasons Why Backup is Strategic

Backup is strategic to your business because your data is strategic to your business. Without backup, your business will fail. This white paper explains why it is vital for you to design and immediately execute a backup strategy to protect 100 percent of your data.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In a multiple monitor setup, if you don't want to use AutoCenter to position your popup forms, you have a problem: where will they appear?  Sometimes you may have an additional problem: where the devil did they go?  If you last had a popup form open…
A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
With Microsoft Access, learn how to specify relationships between tables and set various options on the relationship. Add the tables: Create the relationship: Decide if you’re going to set referential integrity: Decide if you want cascade upda…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

785 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