Open connection to MySQL from VBA Excel 2007 - mysql

I got this error when try to connect Excel and MySQL using ODBC
DataSource name not found and no default driver specified
Here is my VBA code:
Sub test123()
' Connection variables
Dim conn As New ADODB.Connection
Dim server_name As String
Dim database_name As String
Dim user_id As String
Dim password As String
' Table action variables
Dim i As Long ' counter
Dim sqlstr As String ' SQL to perform various actions
Dim table1 As String, table2 As String
Dim field1 As String, field2 As String
Dim rs As ADODB.Recordset
Dim vtype As Variant
'----------------------------------------------------------------------
' Establish connection to the database
server_name = "127.0.0.1" ' Enter your server name here - if running from a local computer use 127.0.0.1
database_name = "smss" ' Enter your database name here
user_id = "root" ' enter your user ID here
password = "" ' Enter your password here
Set conn = New ADODB.Connection
conn.Open "DRIVER={MySQL ODBC 5.2a Driver}" _
& ";SERVER=" & server_name _
& ";DATABASE=" & database_name _
& ";UID=" & user_id _
& ";PWD=" & password _
' Extract MySQL table data to first worksheet in the workbook
GoTo skipextract
Set rs = New ADODB.Recordset
sqlstr = "SELECT * FROM inbox" ' extracts all data
rs.Open sqlstr, conn, adOpenStatic
With Sheet1(1).Cells ' Enter your sheet name and range here
.ClearContents
.CopyFromRecordset rs
End With
skipextract:
End Sub
I've added references (tools-reference)
The ODBC driver also has been installed.
What is actually wrong? Thank you.

There are many articles on this site describing similar problems. In particular, there were a couple of pointers in this link that rang true.
In your code above, one line in particular struck me as troublesome:
Dim conn As New ADODB.Connection
followed lower down by
Set conn = New ADODB.Connection
The second overrides the first in a way that makes me, for one, uncomfortable - although I can't tell you exactly what is wrong, except that you're creating TWO New Connections...
Try that - and the other fixes recommended in the linked article. Good luck.

maybe this might help you/others:
Add this reference to your project: Microsoft ActiveX Data object 2 (or any higher version you have)
Throw this code into a module and save it:
Edit the server details in this module.
'---------------------------------------------------------------------------------------
' Module : Mod_Connection
' Author : Krish km, xkrishx.wordpress.com
' Date : 27/08/2014
' Purpose : use this for build mysql connectin string.
' Declaration: © Krish KM, 2014.
' : Free to modify and re-use as long as a clear credit is made about the orgin of the code and the link above
' : This script is distributed in the hope that it will be useful,
' : but WITHOUT ANY WARRANTY; without even the implied warranty of
' : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' : GNU General Public License for more details.
'---------------------------------------------------------------------------------------
Option Explicit
Public ConnectionString As String
Private Const HKEY_LOCAL_MACHINE = &H80000002
Public Function GET_CURRENT_DRIVER() As String
'---------------------------------------------------------------------------------------
' Procedure : GET_CURRENT_DRIVER
' Author : Krish km
' Date : 27/08/2014
' Purpose : This function returns available mysql odbc drivers found in the registry. You could search by MySQL ODBC and get the first result
' : but I prefer prioritize the drivers i would like to yield first
'---------------------------------------------------------------------------------------
'
If FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC 5.2 Unicode Driver") <> "" Then
GET_CURRENT_DRIVER = "MySQL ODBC 5.2 Unicode Driver"
ElseIf FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC 5.2w Driver") <> "" Then
GET_CURRENT_DRIVER = "MySQL ODBC 5.2w Driver"
Else
GET_CURRENT_DRIVER = FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC")
End If
End Function
Public Function GET_CONNECTION_STRING() As String
'---------------------------------------------------------------------------------------
' Procedure : GET_CONNECTION_STRING
' Author : Krish KM
' Date : 27/08/2014
' Purpose : Returns MySQL connection string
'---------------------------------------------------------------------------------------
'
If Not ConnectionString = vbNullString Then
GET_CONNECTION_STRING = ConnectionString
Else
Dim Driver As String
Dim mDatabase As String
Dim mServer As String
Dim mUser As String
Dim mPassword As String
Dim mPort As Integer
mDatabase = "" ' DB name
mServer = "" ' Server name
mUser = "" ' DB user name
mPassword = "" ' DB user password
mPort = 3306 ' DB port
Driver = GET_CURRENT_DRIVER
If Driver = "" Then
Err.Raise 1, Err.Source, "MYSQL ODBC drivers are missing"
Exit Function
End If
ConnectionString = "DRIVER={" & Driver & "};PORT=" & mPort & ";DATABASE=" & mDatabase & ";SERVER={" & mServer & "};UID=" & mUser & ";PWD={" & mPassword & "};"
GET_CONNECTION_STRING = ConnectionString
End If
End Function
Public Function GET_ODBC_DRIVER_NAMES()
'---------------------------------------------------------------------------------------
' Procedure : GET_ODBC_DRIVER_NAMES
' Author : Krish KM
' Date : 27/08/2014
' Purpose : Checks in the registry for any odbc driver signatures and returns the collection
'---------------------------------------------------------------------------------------
'
Dim strComputer As String, strKeyPath As String
Dim objRegistry As Object, arrValueNames, arrValueTypes
strComputer = "."
strKeyPath = "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers"
Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
objRegistry.EnumValues HKEY_LOCAL_MACHINE, strKeyPath, arrValueNames, arrValueTypes
GET_ODBC_DRIVER_NAMES = arrValueNames
End Function
Public Function FIND_ODBC_DRIVER(ByVal iArr, ByVal sValue) As String
'---------------------------------------------------------------------------------------
' Procedure : FIND_ODBC_DRIVER
' Author : Krish KM
' Date : 27/08/2014
' Purpose : Simple array function to check if a specific value exists. if yes return the value if not return empty string
'---------------------------------------------------------------------------------------
'
FIND_ODBC_DRIVER = ""
Dim iValue As Variant
For Each iValue In iArr
If iValue = sValue Then
FIND_ODBC_DRIVER = iValue
Exit Function
End If
Next
End Function
Copy/modify this function on your excel sheet button/macro:
update the SQL_GET statement as per your request/sql call.
Sub Retrieve_EMP_Details()
'---------------------------------------------------------------------------------------
' Procedure : Retrieve_EMP_Details
' Author : Krish KM
' Date : 27/08/2014
' Purpose : connects to the database and retrieves employee details.
'---------------------------------------------------------------------------------------
'
'Connection variables
Dim conn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As ADODB.Recordset
'Get connection string and connect to the server
On Error GoTo ERR_CONNECTION:
conn.ConnectionString = GET_CONNECTION_STRING ' trap additional error if you want
conn.Open
'Preparing SQL Execution
Dim SQL_GET As String
SQL_GET = "SELECT * FROM tbl_employee" ' extracts all data
cmd.Name = "EMPSearch"
cmd.ActiveConnection = conn
cmd.CommandText = SQL_GET
'Execute SQL
Set rs = cmd.Execute
On Error GoTo ERR_READ_SQL
If Not rs.EOF Then
With Sheets(1).Cells ' Enter your sheet name and range here
.ClearContents
.CopyFromRecordset rs
End With
Else
Sheets(1).Range("A1").value = "No records found :("
End If
EXIT_SUB:
On Error Resume Next
Set conn = Nothing
Set cmd = Nothing
Set rs = Nothing
Exit Sub
ERR_CONNECTION:
MsgBox "Sorry unable to connect to the server.." & vbNewLine & "Connection string: " & GET_CONNECTION_STRING & vbNewLine & "System Msg: " & Err.Description
GoTo EXIT_SUB
ERR_READ_SQL:
MsgBox "Sorry unable read/wite results on the sheet.." & vbNewLine & "System Msg: " & Err.Description
GoTo EXIT_SUB
End Sub
If you have ODBC drivers installed, all the server details provided, SQL statement adjusted. just execute the sub_routine {Retrieve_EMP_Details} and you should be able to see the results in sheet(1)
Hope this helps and enjoy :)
Krish KM

Related

Are there equivalents to ADODB.connection ADODB.recordset in Excel for Mac 2016?

... or pull records from QueryTables.
try this srting:
SQLDatabase_VBA.bas
connect SQL Database from ADODB or system with VBA in Excel
sconnect = "Provider=MSDASQL.1;DSN=your ODBC connection name; " & _
"UID=your user;PWD=your password;DBQ=your database" & DBPath & ";HDR=Yes';"
connection String for IBM/AS400: (without ADODB, maybe work on mac but only eith IBM server)
sconnect = "PROVIDER=IBMDA400;Data Source=servername; " & _
"DEFAULT COLLECTION=optional;USER ID=Username ;PASSWORD=KENNWORT"
SQLDatabase_VBA.bas :
Sub SQLDatabase_VBA()
On Error Resume Next
'Step 1: Create the Connection String with Provider and Data Source options
Public sSQLQry As String
Public ReturnArray
Public Conn As New ADODB.Connection
Public mrs As New ADODB.Recordset
Public DBPath As String, sconnect As String
'Step 2: Create the Connection String with Provider and Data Source options
ActiveSheet.Activate
DBPath = ThisWorkbook.FullName 'Refering the sameworkbook as Data Source
'You can provide the full path of your external file as shown below
'DBPath ="C:\InputData.xlsx"
sconnect = "Provider=MSDASQL.1;DSN=Connect_fromODBC;UID=your user name;PWD=your password;DBQ=database name" & DBPath & ";HDR=Yes';"
'If any issue with MSDASQL Provider, Try the Microsoft.Jet.OLEDB:
'sconnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBPath _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
'Step 3: set connection timeout Open the Connection to data source
Conn.ConnectionTimeout = 30
Conn.Open sconnect
'Step 4: Create SQL Command String MRFIRM, MRIDEN, MRSART,MRSRN,MRSRRF,MRDTB,MRUSER, MRSRNA as Serien_NR_Zugriff
sSQLSting = "SELECT * From your database " & _
" WHERE ------ " & _
" Group by ----- "
'Step 5: Get the records by Opening this Query with in the Connected data source
mrs.Open sSQLSting, Conn
'Step 6: Copy the reords into our worksheet
'Import Headers
For i = 0 To mrs.Fields.Count - 1
ActiveSheet.Range("B15").Offset(0, i) = mrs.Fields(i).Name
Next i
'Import data to destination cell
ActiveSheet.Range("B15").Offset(1, 0).CopyFromRecordset mrs
'Step 7: Close the Record Set and Connection
'Close Recordset
mrs.Close
'Close Connection
Conn.Close
Set mrs = Nothing
Set Conn = Nothing
End Sub

ADODB - VBA - MySQL - SHOW TABLES Syntax

I have a connection through VBA to a MySQL database but I can't determine the proper syntax to return the values from a SHOW TABLES query.
Dim rs As Object
Dim ws As Worksheet
Dim sqlstr As String
Set rs = CreateObject("ADODB.Recordset")
Set ws = ThisWorkbook.Worksheets(1)
sqlstr = "SHOW TABLES"
Call connectDatabase
rs.Open sqlstr, DBCONT
For i = 0 To (rs.RecordCount - 1)
ws.Cells(i+1, 1).value = rs(i)
rs.movenext
Next i
rs.Close
Set rs = Nothing
Call closeDatabase
The error statement reads as:
Run-time error '3265' - Item cannot be found in the collection
corresponding to the requested name or ordinal.
This exact same code works perfectly when I am trying to view the results from a "SHOW COLUMNS FROM tableName" query and also from a "SELECT columnName1 FROM tableName" query. I assume the error is that the Table names are not supposed to return as a Recordset???
As requested, this is how I connect to my database:
Public DBCONT As Object
Public Function connectDatabase()
Set DBCONT = CreateObject("ADODB.Connection")
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim Port As String
Dim sConn As String
Server_Name = "localhost"
Database_Name = "databaseName"
User_ID = "userID"
Password = "password"
Port = "3306"
sConn = "Driver={MySQL ODBC 5.1 Driver};Server=" & _
Server_Name & ";Database=" & Database_Name & _
";UID=" & User_ID & ";PWD=" & Password & ";Option=3;"
DBCONT.Open sConn
DBCONT.cursorlocation = 3
End Function
This is how I close my database:
Public Function closeDatabase()
On Error Resume Next
DBCONT.Close
Set DBCONT = Nothing
On Error GoTo 0
End Function
Answered by barrowc in the comments:
In general, you could replace the whole For..Next loop with ws.Cells(1, 1).CopyFromRecordset rs Not sure if it would help with this specific error though – barrowc Apr 8 at 23:54

Using form combo box to change server name of connection string

I am setting up an access form to enter the parameters for a query, as well as select the needed database server to connect to. This will need to be run to gather data from multiple buildings, each of which has a different server name. All table names and fields are universal.
I have the server names, universal ID and PW, database name, network name, and port used to connect to the SQL servers. All are the same for all buildings, except server name. So only the server name will need to be changed in the connection string. All of this info is saved in a table.
I've read several posts from stack and other sites but cant quite get anything to work.
What I want to be able to do is to use a combo box to select the building name that I want to connect to, and have that combo box output the server name for that building. (This I know how to do within the properties window) And then have the VBA code update the linked tables to the new server.
What I do not know/understand is how to pass the combo box output into a VBA variable to be used in the connection string, nor write the code to update the connection string. Most of what I have found has been how to change DSN to DSN-less, or change specific tables. I want to update all the linked tables at once.
Id like to understand generally how the code works, so any ELI5 comments are greatly appreciated.
Here is a function to create a connection string:
Public Function ConnectionString( _
ByVal Hostname As String, _
ByVal Database As String, _
ByVal Username As String, _
ByVal Password As String) _
As String
' Create ODBC connection string from its variable elements.
' 2016-04-24. Cactus Data ApS, CPH.
Const AzureDomain As String = ".windows.net"
Const OdbcConnect As String = _
"ODBC;" & _
"DRIVER=SQL Server Native Client 11.0;" & _
"Description=Your Application;" & _
"APP=Microsoft® Access;" & _
"SERVER={0};" & _
"DATABASE={1};" & _
"UID={2};" & _
"PWD={3};" & _
"Trusted_Connection=No;"
Dim FullConnect As String
If Right(Hostname, Len(AzureDomain)) = AzureDomain Then
' Azure SQL connection.
' Append servername to username.
Username = Username & "#" & Split(Hostname)(0)
End If
FullConnect = OdbcConnect
FullConnect = Replace(FullConnect, "{0}", Hostname)
FullConnect = Replace(FullConnect, "{1}", Database)
FullConnect = Replace(FullConnect, "{2}", Username)
FullConnect = Replace(FullConnect, "{3}", Password)
ConnectionString = FullConnect
End Function
And here is a function to relink the tables and pass-trough queries:
Public Function AttachSqlServer( _
ByVal Hostname As String, _
ByVal Database As String, _
ByVal Username As String, _
ByVal Password As String) _
As Boolean
' Attach all tables linked via ODBC to SQL Server or Azure SQL.
' 2016-04-24. Cactus Data ApS, CPH.
Const cstrQuery1 As String = "_Template"
Const cstrQuery2 As String = "_TemplateRead"
Const cstrQuery3 As String = "VerifyConnection"
Const cstrDbType As String = "ODBC"
Const cstrAcPrefix As String = "dbo_"
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim strConnect As String
Dim strName As String
On Error GoTo Err_AttachSqlServer
Set dbs = CurrentDb
strConnect = ConnectionString(Hostname, Database, Username, Password)
For Each tdf In dbs.TableDefs
strName = tdf.Name
If Asc(strName) <> Asc("~") Then
If InStr(tdf.Connect, cstrDbType) = 1 Then
If Left(strName, Len(cstrAcPrefix)) = cstrAcPrefix Then
tdf.Name = Mid(strName, Len(cstrAcPrefix) + 1)
End If
tdf.Connect = strConnect
tdf.RefreshLink
Debug.Print Timer, tdf.Name, tdf.SourceTableName, tdf.Connect
DoEvents
End If
End If
Next
dbs.QueryDefs(cstrQuery1).Connect = strConnect
dbs.QueryDefs(cstrQuery2).Connect = strConnect
dbs.QueryDefs(cstrQuery3).Connect = strConnect
Debug.Print "Done!"
AttachSqlServer = True
Exit_AttachSqlServer:
Set tdf = Nothing
Set dbs = Nothing
Exit Function
Err_AttachSqlServer:
Call ErrorMox
Resume Exit_AttachSqlServer
End Function
This should get you going.

Access 2010 linked to SQL Server 2008 tables - unable to change tabledef.connection to SQL Server Authentication DSN-Less

I usually link SQL Server 2008 tables in Access 2010 via DSN for development, then make it DSN-Less via VBA code (see below).
I've now decided to make the connection SQl Server authentication, rather than windows, as I want anyone to access the database. Problem is, when I link, saving passwords, then run my code to make DSN-less, it doesn't save the SQL Server authentication userID and password. I'm really baffled.
I'm trying to change from:
ODBC;DSN=Organisations_sql8;UID=xx;PWD=x;APP=Microsoft Office 2010;DATABASE=Organisations
To this as checked in debug:
ODBC;DRIVER={SQL Server Native Client 10.0};DATABASE=Organisations;SERVER=ra_sql8;UID=xx;PWD=x;
But this is what is saved:
DRIVER=SQL Server Native Client 10.0;SERVER=ra_sql8;APP=Microsoft Office 2010;DATABASE=Organisations;
Any ideas? :)
Many thanks
Type TableDetails
TableName As String
SourceTableName As String
Attributes As Long
IndexSQL As String
Description As Variant
End Type
Private Sub SubmitFix()
Call FixConnections("ra_sql8", "Organisations", "UserID", "Password")
End Sub
Sub FixConnections( _
ServerName As String, _
DatabaseName As String, _
Optional UID As String, _
Optional PWD As String _
)
' This code was originally written by
' Doug Steele, MVP AccessMVPHelp#gmail.com
' Modifications suggested by
' George Hepworth, MVP ghepworth#gpcdata.com
'
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This subroutine looks for any TableDef objects in the
' database which have a connection string, and changes the
' Connect property of those TableDef objects to use a
' DSN-less connection.
' It then looks for any QueryDef objects in the database
' which have a connection string, and changes the Connect
' property of those pass-through queries to use the same
' DSN-less connection.
' This specific routine connects to the specified SQL Server
' database on a specified server.
' If a user ID and password are provided, it assumes
' SQL Server Security is being used.
' If no user ID and password are provided, it assumes
' trusted connection (Windows Security).
'
' Inputs: ServerName: Name of the SQL Server server (string)
' DatabaseName: Name of the database on that server (string)
' UID: User ID if using SQL Server Security (string)
' PWD: Password if using SQL Server Security (string)
'
On Error GoTo Err_FixConnections
Dim dbCurrent As DAO.Database
Dim prpCurrent As DAO.Property
Dim tdfCurrent As DAO.TableDef
Dim qdfCurrent As DAO.QueryDef
Dim intLoop As Integer
Dim intToChange As Integer
Dim strConnectionString As String
Dim strDescription As String
Dim strQdfConnect As String
Dim typNewTables() As TableDetails
' Start by checking whether using Trusted Connection or SQL Server Security
If (Len(UID) > 0 And Len(PWD) = 0) Or (Len(UID) = 0 And Len(PWD) > 0) Then
MsgBox "Must supply both User ID and Password to use SQL Server Security.", _
vbCritical + vbOKOnly, "Security Information Incorrect."
Exit Sub
Else
If Len(UID) > 0 And Len(PWD) > 0 Then
' Use SQL Server Security
strConnectionString = "ODBC;DRIVER={sql server};" & _
"DATABASE=" & DatabaseName & ";" & _
"SERVER=" & ServerName & ";" & _
"UID=" & UID & ";" & _
"PWD=" & PWD & ";"
Else
' Use Trusted Connection
strConnectionString = "ODBC;DRIVER={sql server};" & _
"DATABASE=" & DatabaseName & ";" & _
"SERVER=" & ServerName & ";" & _
"Trusted_Connection=YES;"
End If
End If
intToChange = 0
Set dbCurrent = DBEngine.Workspaces(0).Databases(0)
' Build a list of all of the connected TableDefs and
' the tables to which they're connected.
For Each tdfCurrent In dbCurrent.TableDefs
If Len(tdfCurrent.Connect) > 0 Then
If UCase$(Left$(tdfCurrent.Connect, 5)) = "ODBC;" Then
ReDim Preserve typNewTables(0 To intToChange)
Debug.Print "------------------------------"
typNewTables(intToChange).Attributes = tdfCurrent.Attributes
Debug.Print tdfCurrent.Attributes
typNewTables(intToChange).TableName = tdfCurrent.Name
Debug.Print tdfCurrent.Name
Debug.Print tdfCurrent.Connect
typNewTables(intToChange).SourceTableName = tdfCurrent.SourceTableName
Debug.Print tdfCurrent.SourceTableName
typNewTables(intToChange).IndexSQL = GenerateIndexSQL(tdfCurrent.Name)
typNewTables(intToChange).Description = Null
typNewTables(intToChange).Description = tdfCurrent.Properties("Description")
intToChange = intToChange + 1
End If
End If
Next
' Loop through all of the linked tables we found
Debug.Print "===================================="
For intLoop = 0 To (intToChange - 1)
' Delete the existing TableDef object
dbCurrent.TableDefs.Delete typNewTables(intLoop).TableName
Debug.Print "------------------------------"
' Create a new TableDef object, using the DSN-less connection
Set tdfCurrent = dbCurrent.CreateTableDef(typNewTables(intLoop).TableName)
tdfCurrent.Connect = strConnectionString
Debug.Print tdfCurrent.Name
Debug.Print tdfCurrent.Connect
' Unfortunately, I'm current unable to test this code,
' but I've been told trying this line of code is failing for most people...
' If it doesn't work for you, just leave it out.
'tdfCurrent.Attributes = typNewTables(intLoop).Attributes
tdfCurrent.SourceTableName = typNewTables(intLoop).SourceTableName
dbCurrent.TableDefs.Append tdfCurrent
' Where it existed, add the Description property to the new table.
If IsNull(typNewTables(intLoop).Description) = False Then
strDescription = CStr(typNewTables(intLoop).Description)
Set prpCurrent = tdfCurrent.CreateProperty("Description", dbText, strDescription)
tdfCurrent.Properties.Append prpCurrent
End If
' Where it existed, create the __UniqueIndex index on the new table.
If Len(typNewTables(intLoop).IndexSQL) > 0 Then
dbCurrent.Execute typNewTables(intLoop).IndexSQL, dbFailOnError
End If
Next
' Loop through all the QueryDef objects looked for pass-through queries to change.
' Note that, unlike TableDef objects, you do not have to delete and re-add the
' QueryDef objects: it's sufficient simply to change the Connect property.
' The reason for the changes to the error trapping are because of the scenario
' described in Addendum 6 below.
For Each qdfCurrent In dbCurrent.QueryDefs
On Error Resume Next
strQdfConnect = qdfCurrent.Connect
On Error GoTo Err_FixConnections
If Len(strQdfConnect) > 0 Then
If UCase$(Left$(qdfCurrent.Connect, 5)) = "ODBC;" Then
qdfCurrent.Connect = strConnectionString
End If
End If
strQdfConnect = vbNullString
Next qdfCurrent
End_FixConnections:
Set tdfCurrent = Nothing
Set dbCurrent = Nothing
Exit Sub
Err_FixConnections:
' Specific error trapping added for Error 3291
' (Syntax error in CREATE INDEX statement.), since that's what many
' people were encountering with the old code.
' Also added error trapping for Error 3270 (Property Not Found.)
' to handle tables which don't have a description.
Select Case err.Number
Case 3270
Resume Next
Case 3291
MsgBox "Problem creating the Index using" & vbCrLf & _
typNewTables(intLoop).IndexSQL, _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
Case 18456
MsgBox "Wrong User ID or Password.", _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
Case Else
MsgBox err.Description & " (" & err.Number & ") encountered", _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
End Select
End Sub
Function GenerateIndexSQL(TableName As String) As String
' This code was originally written by
' Doug Steele, MVP AccessMVPHelp#gmail.com
' Modifications suggested by
' George Hepworth, MVP ghepworth#gpcdata.com
'
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Description: Linked Tables should have an index __uniqueindex.
' This function looks for that index in a given
' table and creates an SQL statement which can
' recreate that index.
' (There appears to be no other way to do this!)
' If no such index exists, the function returns an
' empty string ("").
'
' Inputs: TableDefObject: Reference to a Table (TableDef object)
'
' Returns: An SQL string (or an empty string)
'
On Error GoTo Err_GenerateIndexSQL
Dim dbCurr As DAO.Database
Dim idxCurr As DAO.Index
Dim fldCurr As DAO.Field
Dim strSQL As String
Dim tdfCurr As DAO.TableDef
Set dbCurr = CurrentDb()
Set tdfCurr = dbCurr.TableDefs(TableName)
If tdfCurr.Indexes.Count > 0 Then
' Ensure that there's actually an index named
' "__UnigueIndex" in the table
On Error Resume Next
Set idxCurr = tdfCurr.Indexes("__uniqueindex")
If err.Number = 0 Then
On Error GoTo Err_GenerateIndexSQL
' Loop through all of the fields in the index,
' adding them to the SQL statement
If idxCurr.Fields.Count > 0 Then
strSQL = "CREATE INDEX __UniqueIndex ON [" & TableName & "] ("
For Each fldCurr In idxCurr.Fields
strSQL = strSQL & "[" & fldCurr.Name & "], "
Next
' Remove the trailing comma and space
strSQL = Left$(strSQL, Len(strSQL) - 2) & ")"
End If
End If
End If
End_GenerateIndexSQL:
Set fldCurr = Nothing
Set tdfCurr = Nothing
Set dbCurr = Nothing
GenerateIndexSQL = strSQL
Exit Function
Err_GenerateIndexSQL:
' Error number 3265 is "Not found in this collection
' (in other words, either the tablename is invalid, or
' it doesn't have an index named __uniqueindex)
If err.Number <> 3265 Then
MsgBox err.Description & " (" & err.Number & ") encountered", _
vbOKOnly + vbCritical, "Generate Index SQL"
End If
Resume End_GenerateIndexSQL
End Function
With thanks to Doug Steele and George Hepworth, the fix this issue is to simply change the line of code:
tdfCurrent.Attributes = typNewTables(intLoop).Attributes
to
tdfCurrent.Attributes = typNewTables(intLoop).Attributes And DB_ATTACHSAVEPWD
I've tested this and it works great; SQL Server authentication is now working from Access 2010 using a DSN-Less connection.

VBScript Error 80040E14 Syntax error in FROM clause

I'm trying to use a script I found on the internet to allow the bulk creation of new user accounts in Active Directory using VBScript and a CSV file. I'm not using CSVDE b/c this script will also create passwords. I keep encountering this error when running the code I cannot figure it out. Can anyone help?
'*********************************************************************
' Script: createUsersFromCSV.vbs *
' Creates new user accounts in Active Directory from a CSV file. *
' Input: CSV file with layout logonname,firstname,lastname,password *
' *
'*********************************************************************
Option Explicit
Dim sCSVFileLocation
Dim sCSVFile
Dim oConnection
Dim oRecordSet
Dim oNewUser
' Variables needed for LDAP connection
Dim oRootLDAP
Dim oContainer
' Holding variables for information import from CSV file
Dim sLogon
Dim sFirstName
Dim sLastName
Dim sDisplayName
Dim sPassword
Dim nPwdLastSet
Dim nUserAccountControl ' Used to enable the account
Dim sDomain
Dim sCompany
Dim sPhone
Dim sEmail
Dim sDescription
Dim NumChar, Count, strRdm, intRdm
Dim fso, f, fso1, f1
'* Modify this to match your company's AD domain
sDomain="mydomain.local"
'* Input file location
sCSVFileLocation = "C:\Documents and Settings\Administrator\Desktop\" 'KEEP TRAILING SLASH!
'* Full path to input file
sCSVFile = sCSVFileLocation&"newusers.csv"
' Commands used to open the CSV file and select all of the records
set oConnection = createobject("adodb.connection")
set oRecordSet = createobject("adodb.recordset")
oConnection.open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & _
sCSVFileLocation & ";Extended Properties=""text;HDR=NO;FMT=Delimited"""
oRecordSet.open "SELECT * FROM " & sCSVFile ,oConnection
' Create a connection to an Active Directory OU container.
Set oRootLDAP = GetObject("LDAP://rootDSE")
Set oContainer = GetObject("LDAP://ou=Test," & _
oRootLDAP.Get("defaultNamingContext"))
on error resume next
do until oRecordSet.EOF ' Reads the values (cells) in the sInputFile file.
' --------- Start creating user account
' Read variable information from the CSV file
' and build everything needed to create the account
sLogon = oRecordSet.Fields.Item(0).value
sFirstName = oRecordSet.Fields.Item(1).value
sLastName = oRecordSet.Fields.Item(2).value
sDisplayName = sFirstName&" "&sLastName
sPassword = oRecordSet.Fields.Item(3).value
' Build the User account
Set oNewUser = oContainer.Create("User","cn="&sFirstName&" "&sLastName)
oNewUser.put "sAMAccountName",lcase(sLogon)
oNewUser.put "givenName",sFirstName
oNewUser.put "sn",sLastName
oNewUser.put "UserPrincipalName",lcase(SLogon)&"#"&sDomain
oNewUser.put "DisplayName",sDisplayName
oNewUser.put "name",lcase(sLogon)
' Write this information into Active Directory so we can
' modify the password and enable the user account
oNewUser.SetInfo
' Change the users password
oNewUser.SetPassword sPassword
oNewUser.Put "pwdLastSet", 0
' Enable the user account
oNewUser.Put "userAccountControl", 512
oNewUser.SetInfo
objFile.Close
'*******************
oRecordset.MoveNext
Loop
'*******************
' Used only for debugging
'if err.number = -2147019886 then
' msgbox "User logon " & sLogon & "already exists"
'End If
' --------- End of user account creation
Here is where the error is occuring, line 51 char 1:
oRecordSet.open "SELECT * FROM " & sCSVFile ,oConnection
Maybe sCSVFile contains special characters and therefore must be escaped like this:
oRecordSet.open "SELECT * FROM [" & sCSVFile & "]", oConnection
I hope it helps.