Random Import/Export From Access Fatal Error

[pgag45]

I don't remember specifically changing any code that dealt with the importing and exporting of Access DB's into my Excel Project, but now when I try to import I get the following error which completely crashes Excel...

Run-time error "-2147417848"

Automation error: The object invoked has disconnected from its clients.

Anyone have any idea why this would be thrown? I'm at a complete loss..

Thanks,

Pg

[pgag45]

This is one example of an import I am using... this code has been working for me for a long time and now is throwing this automation error exception..

The strange thing is that in an older version of the workbook I am using (which happens to be located in a different directory) all this code works fine... I am trying to retrace all my steps to see what I have changed (which is a lot) from the older workbook to my current one...

Public Sub importEvents()
MsgBox ("Please select a valid userDB")
newFN = Application.GetOpenFilename(filefilter:="Access Files (*.mdb), *.mdb", Title:=vNum)
If newFN = False Then
    MsgBox ("No file selected")
    Exit Sub
End If
 
If checkTableExists("EVENTS", newFN) = False Then
    MsgBox ("No Events exists in that database")
    Exit Sub
End If
 
For Each shtnext In Sheets
   If shtnext.name = "EVENTS" Then 'Search/Delete charts w/ same name
        Application.DisplayAlerts = False 'No delete prompt
        Sheets("EVENTS").Delete
        Application.DisplayAlerts = True
   End If
Next shtnext
 
Application.ScreenUpdating = False
Sheets.Add
ActiveSheet.name = "EVENTS"
Application.DisplayAlerts = False
Set dbs = OpenDatabase(newFN)
Cells.Select
Selection.Clear
[A1].Select
 
Set rst = dbs.OpenRecordset("EVENTS", dbOpenDynaset, dbReadOnly)
For Each fld In rst.Fields
    i = i + 1
    ActiveSheet.Cells(1, i).Value = fld.name
Next fld
 
ActiveSheet.Cells(2, 1).CopyFromRecordset rst
ActiveSheet.UsedRange.Columns.AutoFit
ActiveSheet.Cells.CreateNames Top:=True, Left:=False, Right:=False, bottom:=False
dbs.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

[pgag45]

Also to add on...

The import works the first time... but fails the second time around.

[anhn]

I am not sure but may be memory leaks, some improvement suggestions:

After line 18, add: Exit For : after delete the sheet you don't need to loop again.

After line 37, add:
rst.Close
Set rst = Nothing

After line 40, add:
Set dbs = Nothing

Question: How you do checkTableExists("EVENTS", newFN) before you open the database? Can you show that function?

[pgag45]

let me try making those changes.. thanks for the help anhn...

Here is the checktableexists function: doesn't actually open the database.. just checks to make sure that table is named in that database.

Function checkTableExists(tableName As String, dbSource As Variant) As Boolean
Dim db As Database
Dim td As TableDef
 
Set db = OpenDatabase(dbSource)
For Each td In db.TableDefs
    If UCase(tableName) = UCase(td.name) Then
        checkTableExists = True
        Set db = Nothing
        Exit Function
    End If
Next td
 
Set db = Nothing
checkTableExists = False
 
End Function

[pgag45]

made those changes.. crashing still occurs after second execution of said code...

Although I did change checkTableExists to

Function checkTableExists(tableName As String, dbSource As Variant) As Boolean
Dim db As Database
Dim td As TableDef
 
Set db = OpenDatabase(dbSource)
For Each td In db.TableDefs
    If UCase(tableName) = UCase(td.name) Then
        Set db = Nothing
        checkTableExists = True
        Exit Function
    End If
Next td
 
Set db = Nothing
checkTableExists = False
 
End Function

[pgag45]

would having option explicit off matter at all?

[anhn]

Here is the checktableexists function: doesn't actually open the database.. just checks to make sure that table is named in that database.

You actually Open the database in checktableexists() function but you never Close it.

After Set db = Nothing, the database is still opened without any reference.
With recordsets and databases, after finishing using them, you should remember :

rst.Close
Set rst = Nothing

dbs.Close
Set dbs = Nothing

Closing is more critical than setting to Nothing.

Why do you need to call a separate function to check whether a table exist and you have to Open the database twice if the table exist?

You can combine the code of that function in to the Sub.
or:
Past back the database to the Sub that you won't need to open them twice and closing them twice.

would having option explicit off matter at all?

Without Option Explicit doesn't matter with your problem here.
But I recommend you to use Option Explicit at all time, it will save you a lot of headache, particular when you have wrong spelling of variables and usually you can have dropdown list of properties and methods for objects/variables.

Below is the much cleanner code for you:

Option Explicit

Public Sub importEvents()
   Dim dbs As Database
   Dim rst As Recordset
   Dim fld As Field
   Dim ws As Worksheet
   Dim i As Integer
   Dim newFN
   Dim sTitle As String

   sTitle = "Please select a valid user mdb file"
   newFN = Application.GetOpenFilename( _
           FileFilter:="Access Files (*.mdb), *.mdb", Title:=sTitle)
   If newFN = False Then
      MsgBox ("No file selected")
      Exit Sub
   End If
   
   Set dbs = OpenDatabase(newFN)
   
   On Error Resume Next
   '-- Try to open "EVENTS" table
   '-- if it does not exist, an Error will happen.
   Set rst = dbs.OpenRecordset("EVENTS", dbOpenDynaset, dbReadOnly)
   If Err > 0 Then
      '-- suppose no other error can happen
      MsgBox ("No Events exists in that database")
      '-- Close dbs befor exit sub
      dbs.Close
      Set dbs = Nothing
      Exit Sub
   End If
   
   Application.ScreenUpdating = False
   '-- Try to set the worksheet "EVENTS"
   '-- if it exists, no Error will happen: Delete it
   '-- otherwise Clear the error and go on
   Set ws = ThisWorkbook.Worksheets("EVENTS")
   If Err = 0 Then
      Application.DisplayAlerts = False 'No delete prompt
      ws.Delete
      Application.DisplayAlerts = True
   Else
      Err.Clear
   End If
   On Error GoTo 0
   
   '-- Use a Worksheet variable is much better than rely on ActiveSheet
   Set ws = ThisWorkbook.Worksheets.Add
   ws.Name = "EVENTS"
   
   i = 0
   For Each fld In rst.Fields
      i = i + 1
      ws.Cells(1, i) = fld.Name
   Next
   ws.Cells(2, 1).CopyFromRecordset rst
   '-- No longer use rst and dbs: Close them
   rst.Close
   Set rst = Nothing
   dbs.Close
   Set dbs = Nothing
   
   ws.UsedRange.Columns.AutoFit
   '-- CreateNames for UsedRange instead of the whole sheet
   ws.UsedRange.CreateNames Top:=True, Left:=False, Right:=False, Bottom:=False
   
   ws.Select
   ws.Cells(1, 1).Select
   Set ws = Nothing
   
   Application.ScreenUpdating = True
   
End Sub

[pgag45]

hmm.. I appreciate the cleaner code.. Definitely better and more reliable code... but this crash problem persists even with those changes..

I'm starting to think this project is corrupted and I'm going to have to revert back to my older version

thanks for the help though