Help with ADOBD Connection to Access...I'm Stumped

[zach454]

I'm having problems getting an error when trying to open an access database that I can open most times, but when it doesn't open I get the error message: Cannot open database ", You may not have.... or Corrupt file (Something like that). If I close excel and reload then it will work for a while and then all of a sudden it quits again. I have about 8 computers running this same excel file over company network.

When program starts, it accesses 3 access 97' databases, 2 of which just pulls information in and 1 of which will record. It wall was working great but suddenly I just keep getting these errors. When I debug it doesn't help much. The only thing I can think of is when I'm pulling or pushing data to/from databases that when the other users are using it, it won't allow multiple user to access it???

After each procedure I set recordset and connection to nothing. Is that correct? Do I need to use a different way to access access when I have multiple users?


here is a my query code that use to always work:

Sub Pull_Data2()
    Dim objRec As Object
    Dim lngfield As Long

'   Screen updating off
    Application.ScreenUpdating = False

       'define paths
        strDBPath = "G:\Data1\Data2\file.mdb"
        Provider = "Provider=Microsoft.Jet.OLEDB.4.0;"

'   Selects Sheet and Clears old Values
    Sheets("Query").Select
    Range("A2:AG100").Clear

    'Pull Required Query
    strQueryName = Prompt.QueryCBO.Value

    On Error Resume Next
       Set objRec = RunQuery(strDBPath, strQueryName)
    On Error GoTo 0

    If Not objRec Is Nothing Then
        With Sheets("Query").Range("A2")
            For lngfield = 1 To objRec.Fields.Count
                .Cells(1, lngfield).Value = objRec.Fields(lngfield - 1).Name
            Next lngfield
            Call .Offset(1, 0).CopyFromRecordset(objRec)
        End With
    End If
   
    Set objRec = Nothing
    Set Recordset = Nothing
    Set Connection = Nothing

and here is just pulling data in from a table

Sub Pull_Data()
    Dim strDBPath As String
    Dim Cnct As String, Src As String
    Dim Connection As ADODB.Connection
    Dim Recordset As ADODB.Recordset
    Dim col As Integer
    
'   Screen updating off
    Application.ScreenUpdating = False

       'define paths
        strDBPath = "G:\Data1\Data2\file.mdb"
        Provider = "Provider=Microsoft.Jet.OLEDB.4.0;"

'   Update Bar
    ProgressBar.ProgressLBL.Caption = "Gathering PAR data for Shaft Dept..."
    ProgressBar.ProgressLBL2.Caption = strDBPath
    ProgressBar.LabelProgress.Width = 5
    ProgressBar.FrameProgress.Caption = "5%"
    Application.Wait (Now() + CDate("00:00:01"))

'   Selects Sheet and Clears old Values
    Sheets("PARS").Select
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
    Range("A:D").Clear

'   Create RecordSet
    Set Recordset = New ADODB.Recordset
    With Recordset
'       Filter  (SELECT = Field Names  FROM = Table   WHERE = Citeria)
        Src = "SELECT BOM.PARENT, BOM.RUN_LT, BOM.COMPONENT, BOM.QUANTITY"   'Grabs all Field titles
        Src = Src & Chr(13) & "" & Chr(10) & "FROM BOM" & Chr(13) & "" & Chr(10) & "WHERE (BOM.COMPONENT='WC[S]15-112-102') OR (BOM.COMPONENT='WC[R]15-112-102')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-104') OR (BOM.COMPONENT='WC[R]15-112-104')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-120') OR (BOM.COMPONENT='WC[R]15-112-120')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-119') OR (BOM.COMPONENT='WC[R]15-112-119')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-117') OR (BOM.COMPONENT='WC[R]15-112-117')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-116') OR (BOM.COMPONENT='WC[R]15-112-116')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-115') OR (BOM.COMPONENT='WC[R]15-112-115')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-112') OR (BOM.COMPONENT='WC[R]15-112-112')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-113') OR (BOM.COMPONENT='WC[R]15-112-113')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-111') OR (BOM.COMPONENT='WC[R]15-112-111')" & _
        " OR (BOM.COMPONENT='WC[S]15-112-114') OR (BOM.COMPONENT='WC[R]15-112-114')"
        .Open Source:=Src, ActiveConnection:=Provider & _
                             "Data Source=" & strDBPath & ";" & _
                             "Jet OLEDB:Engine Type=5;" & _
                             "Persist Security Info=False;"

'       Write the field names
        For col = 0 To Recordset.Fields.Count - 1
           Range("A1").Offset(0, col).Value = Recordset.Fields(col).Name
        Next '

'       Write the recordset
       Range("A1").Offset(1, 0).CopyFromRecordset Recordset
    
'   Close Access
    Set Recordset = Nothing
    Set Connection = Nothing

 

[RoryA]

You don't appear to be closing either the recordset or the connection before you set the variables to nothing.

 

[zach454]

Ok so I took your advice and Made sure each one had a connection at the start and then I closed the recordset and connection at the end of the procedure. Seemed to be working pretty good, I had it give me the same error a couple times but seemed better.

Then I had 4 other people use the database at the same time hit it hard and I got this error: could not use "; file already in use

This database file is in a folder with permissions set with Read/Write/Modify control for all the users, same with the database. The .mdb database also is set to Shared with no Lock.

I don't understand how this could happen, and I'm baffled and don't know where to go from here. Is there a way I can ENSURE that is the user is in a database while another user is that they can't conflict?


Any help would be greatly appreciated!


thanks!

 

[Micron]

I'm no expert on opening db's from Excel - I prefer to do it the other way. However, a couple of things that I'm wondering about in your case.
- you seem to be using late binding by calling a query or creating a recordset rather than actually creating a database object in Excel, connecting to it, and then opening it to act on its members. You might actually be causing that code to attempt to run before the database is open.
- if each person has their own workbook that they are running, closing or destroying the objects won't have any bearing on anyone else trying to create and use their own (not true if a shared workbook, I think)
- perhaps the db is set to open exclusively by default.
- the queries are action queries and the record locks setting prevents others from running them (you seem to have covered that one).
- I suspect you have ensured the other users can open the db directly as well, which means you could rule out exclusive opening.

If you want to test for anyone having a db open, attempt to open it exclusively in code, but you must do it with early and explicit binding. You will get an error that you can then deal with. Or you can test the folder for an .ldb file, but it is less reliable since these can be left over by abnormal Access shutdowns.
Hope that helps a bit.

 

[xenou]

Ok so I took your advice and Made sure each one had a connection at the start and then I closed the recordset and connection at the end of the procedure. Seemed to be working pretty good, I had it give me the same error a couple times but seemed better.

I would recommend posting code to show what changes you made so we can see what you did.

When program starts, it accesses 3 access 97' databases,

I recommend you not use access 97 file formats. That's nearly 20 years old and is very outdated. Get your mdb's up to 2003 file formats.

 

[zach454]

Thanks for your reply, I definitely apperciate you taking the time to help. What do you mean by binding? And would there be a better way to access the data (either push or pull from/to database) instead of like my copy recordset? I thought since I used AdLockReadOnly that would make sure it was exclusively locked? I used that coding because thats what worked, and I'm learning as I go.

Yes each user (4 others) have full permissions on the excel file, database, and folders that contain them.

 

[Micron]

Early binding basically means you tell the application what to use (the "library") to create an object. Late binding means you let the application figure it out when the code runs and hope it works. For example, if you have set a reference in the vb editor to a DAO library and code like "Dim rs as DAO.Recordset", that is early binding. If you write "Dim rs as Recordset", that is late binding. That is one reason why you set the order of the references from highest preference to lowest. I'm guessing that the order would also come in to play if you reference 2 similar libraries, one version newer than the other, but I've never done that.

As for which way is better, I think it usually comes down to what a coder is most familiar with, which often provides reuseable code. In your case, the problem hasn't been identified and is random, according to your first paragraph. After re-reading all your posts, I get the impression that you're experiencing more than one error. So to solve this, the actual error messages and numbers if possible, as well as a brief description of what was being done is very important. It may be a record conflict, or it could be the way the db is being opened. As Xenou says, you should also post up to date code when you have the error info. I wondered about A97 too - it's ancient.

 

[zach454]

Here is the code I used to "Pull Data" from a database, the 2nd code is data I use to 'Push Data' to the same database. I have about 4-5 users in it at a time. None of them access the SAME record at the same time. It is Access 97', I would use newest, but my company hasn't switch, I don't have a choice unfortunately.

Sub Pull_Data2()
Dim strDBPath As String
Dim Cnct As String, Src As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset

' Screen updating off
Application.ScreenUpdating = False

'Sets Connection and recordset objects
Set Connection = New ADODB.Connection
Set Recordset = New ADODB.Recordset

'Define Path
strDBPath = "C:\Users\" & Environ("UserName") & "\Desktop\Production Tracking\Production_Tracking_SHAFT.mdb"
Provider = "Provider=Microsoft.Jet.OLEDB.4.0;"

' Selects Sheet and Clears old Values
Sheets("Query").Select
Range("A2:AG100").Clear

'Pull Required Query
Prompt.OperatorCOMBO.Value = ""
strQueryName = Prompt.QueryCBO.Value

'Pull_Data2
On Error GoTo err:

'Creates Connection
Cnct = Provider & "Data Source=" & strDBPath & ";" & "Jet OLEDB:Engine Type=5;" & "Persist Security Info=False;" '
Connection.Mode = adModeShareDenyNone
Connection.Open ConnectionString:=Cnct

'Creates Recordset
With Recordset
Src = "SELECT * FROM [" & strQueryName & "]" 'Grabs all Field titles

'Opens Table
.Open Src, Cnct, adOpenForwardOnly, adLockReadOnly

' Write the field names
For col = 0 To .Fields.Count - 1
Range("A2").Offset(0, col).Value = .Fields(col).Name
Next '

' Write the recordset
Range("A2").Offset(1, 0).CopyFromRecordset Recordset

'Close connection right away, if they are open, display message and send email of error
If Recordset.State = adStateOpen Then
Recordset.Close
Set Recordset = Nothing
End If
If Connection.State = adStateOpen Then
Connection.Close
Set Connection = Nothing
End If
End With

' Selects Sheet (Weird loop somehwere here....)
Sheets("Query").Select

'Load Order Numbers in DropDown Filter
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Prompt.FilterOrderNumCBO.Clear
For Each cel In Range("E3:E" & LastRow)
For Each cell In Range("E3:E" & LastRow)
If cel.Value = cell.Value Then
Prompt.FilterOrderNumCBO.AddItem cell.Value
Exit For
End If
Next cell
Next cel

'Format Area
Call Format_Query

'Checks for filter and reapplys
If Sheets("Query").AutoFilterMode = True Then
Selection.AutoFilter 'Clear filter
Range("A2:AG2").Select
Selection.AutoFilter
Range("A1:AG1").Select
Else
Range("A2:AG2").Select
Selection.AutoFilter
Range("A1:AG1").Select
End If

'Sorts by Newest on top
LastRow = Range("B" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("Query").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Query").AutoFilter.Sort.SortFields.Add Key:= _
Range("B2:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Query").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Pulls data into listbox from Access Pull tab
Call OpenQueries

' Screen Updating on and back to Access Pull
Sheets("Query").Select
Application.ScreenUpdating = True

Exit Sub
err:

msg = ("Error: [" & err.Number & "]" & vbNewLine & _
"Error Description: [" & err.Description & "]" & vbNewLine & _
"VBA Procedure: [Pull_Data2]" & vbNewLine & _
"Recordset State: [" & Recordset.State & "]" & vbNewLine & _
"Connection State: [" & Connection.State & "]" & vbNewLine & _
"Date/Time: [" & Now & "]" & vbNewLine & vbNewLine & _
"An error occured while pulling data from [" & strDBPath & "]" & vbNewLine & vbNewLine & "Database is down, close excel and try again.")

'Close connection right away, if they are open, display message and send email of error
If Recordset.State = adStateOpen Then
Recordset.Close
Set Recordset = Nothing
End If
If Connection.State = adStateOpen Then
Connection.Close
Set Connection = Nothing
End If

'Display Message
Ans = MsgBox(msg, vbOKOnly + vbCritical, "Database Error...")

'Send email
Call EmailError(msg)


' Screen Updating on and back to Access Pull
Sheets("Query").Select
Application.ScreenUpdating = True

End Sub


Sub Push_Data()
Dim DBFullName As String
Dim Cnct As String, Src As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim col As Integer
Dim SparGoal, RparGoal, TotalGoalPAr, PcPar, ActualRpar, RunPER
Dim ScanTime, EndTime
Dim cel As Range
Dim dtDuration, i

'Set connection and recordset objects
Set Connection = New ADODB.Connection
Set Recordset = New ADODB.Recordset

'Define Path
strDBPath = "C:\Users\" & Environ("UserName") & "\Desktop\Production Tracking\Production_Tracking_SHAFT.mdb"
Provider = "Provider=Microsoft.Jet.OLEDB.4.0;"

' Define variables
Spar = Prompt.SparGoal.Value
Rpar = Prompt.PARperPCTXT.Value 'Par/PC
i = 0

'This grabs the Shift the employee belongs to
Sheets("Employees").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Rows
For Each cel In Range("A2:A" & LastRow)
If CStr(cel.Value) = Prompt.OperatorCOMBO.Value Then
Shift = cel.Offset(0, 2).Value
Exit For
End If
Next cel

' Screen updating off
Application.ScreenUpdating = False

' Searchs for Part #
Sheets("Query").Select

'Push_Data
On Error GoTo err:

'Cycle thru Query before opening database
NextRow = Range("F" & Rows.Count).End(xlUp).Row
For Each cel In Sheets("Query").Range("A3:A" & NextRow)
If cel.Value = Prompt.OpenOrderLIST.Value Then
StartTime = cel.Offset(0, 1).Value
Exit For
End If
Next cel

'Creates Connection
Cnct = Provider & "Data Source=" & strDBPath & ";" & "Jet OLEDB:Engine Type=5;" & "Persist Security Info=False;" '
Connection.Mode = adModeShareDenyNone
Connection.Open ConnectionString:=Cnct

'Creates Recordset
Recordset.Open "Production_Tracking", Cnct, adOpenDynamic, adLockOptimistic

'With Record open if starting order or shift skip to add new record
If Prompt.StartSCAN.Caption = "START OF ORDER" Then GoTo newEntry:
If Prompt.StartSCAN.Caption = "START OF SHIFT" Then GoTo newEntry:

'Finds ID value that was click in the OpenOrder Listbox
Recordset.MoveFirst
Recordset.Find "ID ='" & Prompt.OpenOrderLIST.Value & "'"

'Defines variable
IDnum = Prompt.OpenOrderLIST.Value

With Recordset
If ScanPrompt.SelectOPT.Value = "End of Your Shift" Then
'Cycle thru Access Pull sheet to find matching ID number, if found then updates record
'NextRow = Range("F" & Rows.Count).End(xlUp).Row
'For Each cel In Sheets("Query").Range("A3:A" & NextRow)
'If cel.Value = IDNum Then
.Fields("End_Time") = Now
.Fields("Comments") = .Fields("Comments") & " " & ScanPrompt.CommentSCAN.Value & "." 'Add comments together
.Fields("Qty_Ran") = ScanPrompt.QtyRanTXT.Value
.Fields("ES") = "x"
.Fields("Break_R") = ScanPrompt.BreaksCBO.Value

'StartTime = cel.Offset(0, 1).Value
EndTime = Now
ActRpar = RunParFunc(StartTime, EndTime, , ScanPrompt.QtyRanTXT.Value, ScanPrompt.BreaksCBO.Value, ScanPrompt.ActualSpar.Value)
RunPER = RunParFunc(StartTime, EndTime, Rpar, ScanPrompt.QtyRanTXT.Value, ScanPrompt.BreaksCBO.Value, ScanPrompt.ActualSpar.Value)

' Error Resume next for Zero's
On Error Resume Next
.Fields("RunParAct") = Round(ActRpar, 3)
.Fields("Run_%") = RunPER
.Fields("CalcRunGoal") = Round(Rpar * ScanPrompt.QtyRanTXT.Value, 3)
.Fields("CalcRunAct") = Round(ActRpar * ScanPrompt.QtyRanTXT.Value, 3)
On Error GoTo 0

'Display a status message
Prompt.LBLWhatsHappening.Caption = "You have Successfully ended your shift for Order#: " & Prompt.OrderSCAN.Value
Prompt.LBLWhatsHappening.ForeColor = vbBlack
Prompt.LBLWhatsHappening.BackColor = &HC000& 'Green
Prompt.LBLWhatsHappening.Font.Bold = True

End If

If ScanPrompt.SelectOPT.Value = "End of Order" Then
'Cycle thru Access Pull sheet to find matching ID number, if found then updates record
'NextRow = Range("F" & Rows.Count).End(xlUp).Row
'For Each cel In Sheets("Query").Range("A3:A" & NextRow)
'If cel.Value = IDNum Then
.Fields("End_Time") = Now
.Fields("Comments") = .Fields("Comments") & " " & ScanPrompt.CommentSCAN.Value & "." 'Add comments together
.Fields("Qty_Ran") = ScanPrompt.QtyRanTXT.Value
.Fields("EO") = "x"
.Fields("Break_R") = ScanPrompt.BreaksCBO.Value
.Fields("COMPLETED") = Date

'StartTime = cel.Offset(0, 1).Value
EndTime = Now
ActRpar = RunParFunc(StartTime, EndTime, , ScanPrompt.QtyRanTXT.Value, ScanPrompt.BreaksCBO.Value, ScanPrompt.ActualSpar.Value)
RunPER = RunParFunc(StartTime, EndTime, Rpar, ScanPrompt.QtyRanTXT.Value, ScanPrompt.BreaksCBO.Value, ScanPrompt.ActualSpar.Value)

' Error Resume next for Zero's
On Error Resume Next
.Fields("RunParAct") = Round(ActRpar, 3)
.Fields("Run_%") = RunPER
.Fields("CalcRunGoal") = Round(Rpar * ScanPrompt.QtyRanTXT.Value, 3)
.Fields("CalcRunAct") = Round(ActRpar * ScanPrompt.QtyRanTXT.Value, 3)
On Error GoTo 0

'Display a status message
Prompt.LBLWhatsHappening.Caption = "You have Successfully completed Order#: " & Prompt.OrderSCAN.Value
Prompt.LBLWhatsHappening.ForeColor = vbBlack
Prompt.LBLWhatsHappening.BackColor = &HC000& 'Green
Prompt.LBLWhatsHappening.Font.Bold = True



' Returns EOF to false
.MoveFirst

' Closes out remaining records in database matching the citeria below
Do Until .EOF
If .Fields("Order_#").Value = Prompt.OrderSCAN.Value Then
If .Fields("WorkCenter") = Prompt.WorkCenterCOMBO.Value Then
.Fields("End_Date") = Date
'AddQtyRan = (.Fields("Qty_Ran") + AddQtyRan) 'For when order is short
End If
End If
.MoveNext
Loop
End If

' Update Access
.MoveFirst
.Update

' 'Cint for num not string
' If Prompt.WorkCenterCOMBO.Value = "Grinding - 104" Or Prompt.WorkCenterCOMBO.Value = "Balance - 113" Or Prompt.WorkCenterCOMBO.Value = "Magnetizing - 119" Then
' If AddQtyRan < CInt(Prompt.QtySCAN.Value) Then
' QtyShort = (AddQtyRan - Prompt.QtySCAN.Value)
' Call EmailShortOrder(QtyShort, Prompt.OrderSCAN.Value, Prompt.PartNumSCAN.Value, Prompt.DueDateSCAN.Value, .Fields("Qty").Value, Prompt.WorkCenterCOMBO.Value, Prompt.OperatorCOMBO.Value, ScanPrompt.CommentSCAN.Value)
' End If
' End If
End With

' 'Close connection to Access
If Recordset.State = adStateOpen Then
Recordset.Close
Set Recordset = Nothing
End If
If Connection.State = adStateOpen Then
Connection.Close
Set Connection = Nothing
End If

' Screen updating on
Application.ScreenUpdating = True

Exit Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''Code for New entries for SS, SO
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
newEntry:

If Prompt.LBL241.Caption = "" Then Prompt.LBL241.Caption = "N/A"
If Prompt.LBL242.Caption = "" Then Prompt.LBL242.Caption = "N/A"
If Prompt.LBLBAR.Caption = "" Then Prompt.LBLBAR.Caption = "N/A"

With Recordset
.AddNew ' create a new record
.Fields("Operator") = Prompt.OperatorCOMBO.Value
.Fields("WorkCenter") = Prompt.WorkCenterCOMBO.Value
.Fields("Order_#") = Prompt.OrderSCAN.Value
.Fields("Part_#") = Prompt.PartNumSCAN.Value
.Fields("Qty") = Prompt.QtySCAN.Value
.Fields("Due_Date") = Prompt.DueDateSCAN.Value
.Fields("Lower_Level") = Prompt.LBL241.Caption
.Fields("Mid_Level") = Prompt.LBL242.Caption
.Fields("BarStock") = Prompt.LBLBAR.Caption
.Fields("SetupParGoal") = Spar
.Fields("RunParGoal") = Rpar
.Fields("CalcSetupGoal") = Spar
.Fields("Break_S") = 0 'Start values
.Fields("Break_R") = 0
.Fields("Shift") = Shift

If Prompt.StartSCAN.Caption = "START OF SHIFT" Then
.Fields("SS") = "x"
.Fields("Start_Time") = Now
.Fields("DATESTARTED") = Date
'Display a status message
Prompt.LBLWhatsHappening.Caption = "You have Successfully started your shift for Order#: " & Prompt.OrderSCAN.Value
Prompt.LBLWhatsHappening.ForeColor = vbBlack
Prompt.LBLWhatsHappening.BackColor = &HC000& 'Green
Prompt.LBLWhatsHappening.Font.Bold = True
End If

If Prompt.StartSCAN.Caption = "START OF ORDER" Then
.Fields("SO") = "x"
.Fields("Start_Time") = Now
.Fields("DATESTARTED") = Date
'Display a status message
Prompt.LBLWhatsHappening.Caption = "You have Successfully started a new order for Order#: " & Prompt.OrderSCAN.Value
Prompt.LBLWhatsHappening.ForeColor = vbBlack
Prompt.LBLWhatsHappening.BackColor = &HC000& 'Green
Prompt.LBLWhatsHappening.Font.Bold = True
End If

' Update database
.MoveFirst
.Update

End With

'Close connection to Access
If Recordset.State = adStateOpen Then
Recordset.Close
Set Recordset = Nothing
End If
If Connection.State = adStateOpen Then
Connection.Close
Set Connection = Nothing
End If

' Screen Updating on and back to Access Pull
Sheets("Query").Select
Application.ScreenUpdating = True


Exit Sub
err:

msg = ("Error: [" & err.Number & "]" & vbNewLine & _
"Error Description: [" & err.Description & "]" & vbNewLine & _
"VBA Procedure: [Push_Data]" & vbNewLine & _
"Recordset State: [" & Recordset.State & "]" & vbNewLine & _
"Connection State: [" & Connection.State & "]" & vbNewLine & _
"Date/Time: [" & Now & "]" & vbNewLine & vbNewLine & _
"An error occured while adding entry to [" & strDBPath & "]" & vbNewLine & vbNewLine & "Database is down, close excel and try again.")

'Close connection right away, if they are open, display message and send email of error
If Recordset.State = adStateOpen Then
Recordset.Close
Set Recordset = Nothing
End If
If Connection.State = adStateOpen Then
Connection.Close
Set Connection = Nothing
End If

'Display Message
Ans = MsgBox(msg, vbOKOnly + vbCritical, "Database Error...")

'Send email
Call EmailError(msg)


' Screen Updating on and back to Access Pull
Sheets("Query").Select
Application.ScreenUpdating = True

End Sub

 

[Micron]

There is SO much going on here that I doubt I have hit the target. Here's a beginning, for what it's worth.

Dim Recordset, Dim Connection
Check out a list of Access reserved words. You should not be using these!

Set Recordset = New ADODB.Recordset
You don't "Set" a recordset to a new anything - you declare (Dim) it, after which you set it to equal a sql string or other source.
Dim Rs As New adodb.Recordset
Set Rs = db.OpenRecordset("qryRgaFilter", dbOpenDynaset)

Src = "SELECT * FROM [" & strQueryName & "]" This will evaluate to "SELECT * FROM [strQueryName]". Why square brackets, and where's the semicolon?
Src = "SELECT * FROM " & strQueryName & " ;" Why not this?

strDBPath = "C:\Users\" & Environ("UserName") & "\Desktop\Production Tracking\Production_Tracking_SHAFT.mdb"
Suggest assigning the Environ function result to a variable to avoid inner double quotes as well as using different syntax. This function may cause issues with Windows security. Wouldn't that be something if it was the cause!
svUserName = VBA.Environ("UserName")
strDBPath = "C:\Users\" & svUserName & "\Desktop\Production Tracking\Production_Tracking_SHAFT.mdb"

Prompt.OperatorCOMBO.Value = ""
This eludes me. If it is a reference to a form control, it is not correct.
forms!Prompt.... Prompt is not an Access reserved word, but it looks dangerous. Project libraries (references) have their own reserved words and you could easily transgress. You SHOULD read up on naming conventions and use one to minimize the danger. You will never go wrong with frmCount for a user defined object but you will with Count.

With Recordset
Src = "SELECT * FROM [" & strQueryName & "]" 'Grabs all Field titles
When using a with block, each property or method should be proceeded with a "." Src is not one of those. Personally, I would avoid a bunch of if statements and other stuff within the block unless it is specifically required to deal with the recordset. I'm not real familiar with ADODB recordset objects, so I'll use a textbox as an example of what I mean:

If ctl.type = acTextbox then
with ctl
.width =
.height =
.backcolor =
.visible =
end with

OK, I've spent more than an hour digesting your code on this reply. That's all I've got for tonight. I think we're going to need you to post the error message- not some abbreviated interpretation like ".... or Corrupt file (Something like that)." and which line it occurs on.