Excel VBA using ADO to open Access Database - Authentication failed

dmckie250

Registered User.
Local time
Today, 14:10
Joined
Sep 1, 2010
Messages
12
Hi,

I am trying to use VBA to open up an access database, enter values into a record from a series of defined names into a temporary table, then eventually run an append/update query to copy this record into the main table.

At the moment I am struggling with the first step, which is giving me the error:


runtime error 214721783(80040e4d) Authentication failed

This is the code:
Code:
Sub SelectDB()
'Select Database file location
PEMdb  = Application.GetOpenFilename(FileFilter:="Access Files (*.mdb),  *.mdb", Title:="Please select the location of the Personnel &  Equipment Management Database")
If PEMdb = False Then
' They pressed Cancel
MsgBox "The operation was cancelled", vbInformation, "Import Cancelled"

Exit Sub
Else
Workbooks.Open Filename:=PEMdb
End If
End Sub

Sub Validate_Import_1()
'Validate Data before importing

End Sub


Sub Import_Stage_1()
'Export data from excel into Access DB

Call SelectDB

Dim cn As ADODB.Connection
Dim cmPerDet As ADODB.Command


Set cn = New ADODB.Connection
Set cmPerDet = New ADODB.Command

With cn
.CommandTimeout = 0
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.ConnectionString = "Data Source=" & PEMdb & "; Persist Security Info=False"
.Open
End With


With cmPerDet
.CommandText  = "Insert into tbl_TEMP_Personnel_Details(Employee ID, First Name, Last  Name) Values ('" + Range("Employee_ID").Text + "','" +  Range("First_Name").Text + "','" + Range("Last_Name").Text + "')"
.ActiveConnection = cn

End With


End Sub


The database will eventually be split with the back-end on a network drive, but at the moment I am getting this error even when it's located on my own desktop.

Any suggestions? It's the .Open line that is highlighted by the debugger. I have tried both changing selectDB() from a sub to a function and removing it completely (replacing PEMdb with a path & filename) but to no avail...

Thanks,

Duncan
 
Ok - I have changed things around so that instead of using PEMdb as the file path, I am using a global variant called DBlocation:

Code:
Option Explicit
Global DBlocation As Variant

Sub SelectDB()
'Select Database file location

'open dialogue box to choose file
DBlocation = Application.GetOpenFilename(FileFilter:="Access Files (*.mdb), *.mdb", Title:="Please select the location of the Personnel & Equipment Management Database")
'if they press cancel
If DBlocation = False Then
'cancelled message
MsgBox "The operation was cancelled", vbInformation, "Import Cancelled"

Exit Sub
End If
End Sub

Sub Validate_Import_1()
'Validate Data before importing

End Sub


Sub Import_Stage_1()
'Export data from excel into Access DB

Call SelectDB
If DBlocation = False Then
Exit Sub
Else

Dim cn As ADODB.Connection
Dim cmPerDet As ADODB.Command


Set cn = New ADODB.Connection
Set cmPerDet = New ADODB.Command

With cn
.CommandTimeout = 0
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.ConnectionString = "Data Source= " & DBlocation & "; Persist Security Info=False"
.Open
End With


With cmPerDet
.CommandText = "INSERT INTO tbl_TEMP_Personnel_Details([Employee ID], [First Name], [Last Name]) VALUES ('" & Range("Employee_ID").Text & "','" & Range("First_Name").Text & "','" & Range("Last_Name").Text & "')"
.ActiveConnection = cn

End With

End If
End Sub

This avoids errors but it is still not inserting the data into the required table. Could it be a problem with the ' and " in the VALUES section of the SQL?
 
First of all, which line is giving you the authentication error? Please indicate that.

A couple things that may be an issue that I see as well...I have always been under the assumption that multiple specs in an ADO connection string need to be enclose in double quotes:
Code:
"Data Source=" & """" & DBlocation & ";" & " Persist Security Info=False;" & """"
Secondly, at the end of you last sub, you really need to close the connection and de-reference it so it doesn't cause issues with memory. Chances are marginal, but it is still good practice.

Also, would the 'persist security info=false' possibly work better through the properties collection?
Code:
with cn
   .properties("Persist Security Info") = false
I do not know, but some properties and extended can properties can be listed either way, and work in either context....
 
Thanks for your help - I have managed to fix the authentication error - I think it was due to the variant containing the file path not being global and so the file details were not being passed on to the ADO command.

I have made the changes you suggested so the code now looks like this:

Code:
Sub Import_Stage_1()
'Export data from excel into Access DB

Call SelectDB
If DBlocation = False Then
Exit Sub


Dim cn As ADODB.Connection
Dim cmPerDet As ADODB.Command


Set cn = New ADODB.Connection
Set cmPerDet = New ADODB.Command

With cn
.CommandTimeout = 0
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.Properties("Persist Security Info") = False
.ConnectionString = "Data Source= " & DBlocation
.Open
End With


With cmPerDet
.CommandText = "INSERT INTO tbl_TEMP_Personnel_Details([Employee ID], [First Name], [Last Name]) VALUES ('123','Bob','Dave')"
.ActiveConnection = cn

End With

cn.Close

End If
End Sub

There are no errors anymore, but the values still aren't being added into the table.
 
I would use DAO for this instead of ADO. It is much easier.

Code:
Dim db As DAO.Database
 
Dim strSQL As String
 
strSQL = "INSERT INTO tbl_TEMP_Personnel_Details([Employee ID], [First Name], [Last Name]) VALUES ('123','Bob','Dave')"
 
Set db = OpenDatabase(DBlocation)
 
db.Execute strSQL, dbFailOnError
 
db.Close
Set db = Nothing
 
Thanks Bob - that seems to work great.

From there I can build this up and add in the append/update queries. How would I replace '123' with a named range though? i.e.

Code:
strSQL = "INSERT INTO tbl_TEMP_Personnel_Details([Employee ID],  [Last Name], [First Name]) VALUES (" '" & Range("Employee_ID").Value  & "'","'" & Range("Last_Name") & "'","'" &  Range("First_Name") & "'")"

Only one other issue - this method won't work if the user already has the database open - it gives an error saying the database is locked by the user. Is there anyway to avoid this?

Thanks a million!
 
How would I replace '123' with a named range though? i.e.
You would have to iterate through the named range but I'm not sure about that one. I've done a fair amount of Excel coding but not using named ranges. Hopefully someone else can help with that.
Only one other issue - this method won't work if the user already has the database open - it gives an error saying the database is locked by the user. Is there anyway to avoid this?
If this database is properly split (backend tables only and copy of frontend on each user's machine) then it should work as you would be connecting to the backend database.
 
it also needs to be shared-enabled. But I believe this is the default for any database initially, isn't it Bob?

As far as using named ranges are concerned, I've never used them in ADO sql, but I also know that they are treated as actual tables when you use an ADO method for querying. So whether that is useful information or not, I'm not sure. You could check by running a test and executing sql using the named range in braces []. I doubt it would be worth the time though...and you would have to switch back to ADO anyway.
 
If split, then it isn't a problem because the backend is set that way anyway as you aren't using an Access interface but connecting directly.

I think that's what I meant. Basically I was asking if Access files are defaulted to 'shared' instead of 'exclusive'. I believe they are.
 
Thanks guys - got this up and running like a charm now, using an INSERT INTO query to get the data into a temporary table in access, then a stored UPDATE/APPEND query (as described here - http://support.microsoft.com/default.aspx?scid=kb;en-us;127977) that's accessed by a DAO.Querydef, followed by a DELETE query to clear the data from the temporary table.

This is all working fine except for one section - I'm trying to upload a list of Mainframe Application requests into the temporary table and it's being a bit difficult. There are up to six possible requests, each with a Ticket # (primary key), a Mainframe ID (foreign key), an Application name, Date Requested, Date Submitted, Date Completed and Actioned By.

The data capture form is set up so that if an application is not selected, it is given the value "N/A". If the first request is "N/A", the second is automatically "N/A" and so on.

I could just insert each of these requests one-by-one, but I'd like to learn how to use loops so I was wondering if you had any suggestions on how to make this work? At the moment I have this (db is already defined globally as the correct database):

Code:
Sub Upload_Mainframe_Request_Details()
On Error GoTo Err_Upload_Mainframe_Request_Details
'=====================================================
'Upload Mainframe Application Request Details
'=====================================================
Dim strSQL_Mainframe_ID As String
Dim strSQL_Mainframe_Request As String
Dim update_Mainframe_ID As DAO.QueryDef
Dim ID As String
Dim App As String
Dim Ticket_Number As String
Dim Request_Type As String
Dim Request_Received As Date
Dim Request_Submitted As Date
Dim Request_Completed As Date
Dim BSA As String


ID = Range("Mainframe_ID").Text
BSA = Range("Completed_Email_Admin_Name").Text
Request_Type = Range("Mainframe_Request_Type").Text
Request_Received = Range("Completed_Email_Manager_Date").Value

'Upload Mainframe ID
'---------------------------------


'INSERT Mainframe ID query to copy Mainframe ID into Temp table
strSQL_Mainframe_ID = "INSERT INTO tbl_TEMP_Mainframe_ID([Mainframe ID], [Employee ID],)" _
                & "VALUES ('" & ID & "','" & Range("Employee_ID").Text & "');" '<<< [COLOR=Red]this generates 3134 error in INSERT INTO Syntax[/COLOR]

'Run SQL to insert data into table
db.Execute strSQL_Mainframe_ID, dbFailOnError

'Append or Update TEMP Mainframe ID data to full table
'--------------------------------

'Execute update query in access
Set update_Mainframe_ID = db.QueryDefs("qry_UPDATE_Mainframe_ID")
update_Mainframe_ID.Execute


'Upload Mainframe Requests
'---------------------------------

'INSERT Query to upload Mainframe requests
strSQL_Mainframe_Request = "INSERT INTO tbl_Mainframe_Requests([Ticket #], [Mainframe ID], [Request Type], [Application], [Request Received], [Request Submitted], [Request Completed], [Actioned By]) " _
                        & "VALUES ('" & Ticket_Number & "','" & ID & "','" & Request_Type & "','" & App & "','" & Request_Received & "','" & Request_Submitted & "','" & Request_Completed & "','" & BSA & "');"


'Cycle through application requests and upload one-by-one

Mainframe1:
App = Range("Mainframe_1_App").Text
If App = "N/A" Then GoTo Mainframe2
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_1_Ticket").Value
Request_Submitted = Range("Mainframe_1_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_1_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError

End If


Mainframe2: 
App = Range("Mainframe_2_App").Text
If App = "N/A" Then GoTo Mainframe3
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_2_Ticket").Value
Request_Submitted = Range("Mainframe_2_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_2_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError '[COLOR=Red]This stage produces a 3022 error - duplicate primary key - i.e. the code is not generating a new record.[/COLOR]

End If

Mainframe3:
App = Range("Mainframe_3_App").Text
If App = "N/A" Then GoTo Mainframe4
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_3_Ticket").Value
Request_Submitted = Range("Mainframe_3_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_3_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError

End If

Mainframe4:
App = Range("Mainframe_4_App").Text
If App = "N/A" Then GoTo Mainframe5
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_4_Ticket").Value
Request_Submitted = Range("Mainframe_4_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_4_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError

End If

Mainframe5:
App = Range("Mainframe_5_App").Text
If App = "N/A" Then GoTo Mainframe6
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_5_Ticket").Value
Request_Submitted = Range("Mainframe_5_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_5_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError

End If

Mainframe6:
App = Range("Mainframe_1_App").Text
If App = "N/A" Then GoTo Exit_Upload_Mainframe_Request_Details
If App <> "N/A" Then
Ticket_Number = Range("Mainframe_1_Ticket").Value
Request_Submitted = Range("Mainframe_1_Dte_Sbmttd").Value
Request_Completed = Range("Mainframe_1_Dte_Cmpltd").Value

db.Execute strSQL_Mainframe_Request, dbFailOnError

End If


'=====================================================
'Error Handling
Exit_Upload_Mainframe_Request_Details:
Exit Sub
Err_Upload_Mainframe_Request_Details:
    MsgBox "There has been an error in code Upload_Mainframe_Request_Details: " & Chr(10) & Err.Number & " - " & Err.Description, vbExclamation
    Resume Exit_Upload_Mainframe_Request_Details
'=====================================================

End Sub

Any ideas?
 
Just to let you know - I eventually managed to get this to work using DAO recordsets. It took me a while to investigate & figure out what they are and how to use them, but they seem to be simpler to use in some cases than SQL queries so I might be using them a lot more in future!

this is the working code:

Code:
Sub Upload_Mainframe_Request_Details()
'On Error GoTo Err_Upload_Mainframe_Request_Details
'=====================================================
'Upload Mainframe Application Request Details
'=====================================================
Dim strSQL_Mainframe_ID As String
Dim strSQL_Mainframe_Request As String
Dim update_Mainframe_ID As DAO.QueryDef
Dim rs As DAO.Recordset
Dim App As String


'Upload Mainframe ID
'================================

'INSERT Mainframe ID query to copy Mainframe ID into Temp table
strSQL_Mainframe_ID = "INSERT INTO tbl_TEMP_Mainframe_ID ([Mainframe ID], [Employee ID]) " _
                    & "VALUES ('" & Range("Mainframe_ID").Text & "','" & Range("Employee_ID").Text & "');"

'Run SQL to insert data into table
db.Execute strSQL_Mainframe_ID, dbFailOnError

'Append or Update TEMP Mainframe ID data to full table
'--------------------------------

'Execute update query in access
Set update_Mainframe_ID = db.QueryDefs("qry_UPDATE_Mainframe_ID")
update_Mainframe_ID.Execute

Set update_Mainframe_ID = Nothing

'Upload Mainframe Requests
'================================

'Cycle through application requests and upload one-by-one

'Mainframe Request 1
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_1_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_1_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_1_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_1_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_1_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'Mainframe Request 2
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_2_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_2_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_2_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_2_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_2_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'Mainframe Request 3
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_3_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_3_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_3_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_3_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_3_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'Mainframe Request 4
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_4_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_4_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_4_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_4_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_4_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'Mainframe Request 5
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_5_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_5_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_5_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_5_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_5_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'Mainframe Request 6
'---------------------------------

'Check if application has been selected
App = Range("Mainframe_6_App").Text
If App <> "N/A" Then

'create new record in TEMP table with request details
Set rs = db.OpenRecordset("tbl_TEMP_Mainframe_Requests", dbOpenDynaset)
    rs.AddNew
        rs("Ticket #") = Range("Mainframe_6_Ticket").Value
        rs("Mainframe ID") = Range("Mainframe_ID").Value
        rs("Request Type") = Range("Mainframe_Request_Type").Value
        rs("Application") = Range("Mainframe_6_App").Value
        rs("Request Received") = Range("Completed_Email_Manager_Date").Value
        rs("Request Submitted") = Range("Mainframe_6_Dte_Sbmttd").Value
        rs("Request Completed") = Range("Mainframe_6_Dte_Cmpltd").Value
        rs("Actioned By") = Range("Completed_Email_Admin_Name").Value
        
    rs.Update
    rs.Close
Set rs = Nothing
   
End If

'=====================================================
'Error Handling
'Exit_Upload_Mainframe_Request_Details:
'Exit Sub
'Err_Upload_Mainframe_Request_Details:
   ' MsgBox "There has been an error in code Upload_Mainframe_Request_Details: " & Chr(10) & Err.Number & " - " & Err.Description, vbExclamation
    'Resume Exit_Upload_Mainframe_Request_Details
'=====================================================

End Sub

Sub Upload_Shared_Folder_Access_Details()
On Error GoTo Err_Upload_Shared_Folder_Access_Details
'=====================================================
'Upload Shared Folder Access Details
'=====================================================



'=====================================================
'Error Handling
Exit_Upload_Shared_Folder_Access_Details:
Exit Sub
Err_Upload_Shared_Folder_Access_Details:
    MsgBox "There has been an error in code Upload_Shared_Folder_Access_Details: " & Chr(10) & Err.Number & Err.Description, vbExclamation
    Resume Exit_Shared_Folder_Access_Details
'=====================================================

End Sub

Thanks again for all your help!
 

Users who are viewing this thread

Back
Top Bottom