Error connecting to MySQL using VBA (3709 error)

Hi all,
Below is a code that will run every time a particular excel file is opened in order to block unauthorized access.
For this the idea is to check the motherboard serial of the computer and verify if it is registered in a mysql database. If it is not registered it closes the file and otherwise autorize the access.
The Workbook_Open function is responsible for autorize or block the access.
The MBSerialNumber function takes the serial of the motherboard.
The ConnectDB function accesses and performs a search of the MySQL database verifying if the serial of the computer is registered.

At this last function I'm having error 3709 (line 4 from bottom to top). I would like your help to solve this problem.

Code:

---

Public cn As Variant
  Private Sub Workbook_Open()
    Call MBSerialNumber
    Call ConnectDB
    If rs < 1 Then
        MsgBox ("Data Security failier, This workbook will close")
        ActiveWorkbook.Save
        ActiveWorkbook.Close
    End If
  End Sub
  Public Function MBSerialNumber() As String
    Dim objs As Object
    Dim obj As Object
    Dim WMI As Object
    Dim sAns As String
    Set WMI = GetObject("WinMgmts:")
    Set objs = WMI.InstancesOf("Win32_BaseBoard")
    For Each obj In objs
        sAns = sAns & obj.SerialNumber
        If sAns < objs.Count Then sAns = sAns & ","
    Next
    MBSerialNumber = sAns
  End Function
  Private Sub ConnectDB()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "DRIVER={MySQL ODBC 5.3 ANSI Driver};" & _
        "SERVER=***.com.br;" & _
        "DATABASE=***_***;" & _
        "USER=***_***;" & _
        "PASSWORD=******"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT COUNT(serial) FROM users WHERE serial='" & MBSerialNumber & "', cn, adOpenStatic, adLockOptimistic"";"
    cn.Close
    Set cn = Nothing
  End Sub

---

follow a excel exemplo with error.

First off, I would recommend using Option Explicit as the first line of code in your Module.

You used late binding but also used early binding constants. The values are 3. Those would have not worked anyway since you enclosed them inside the quotes.

Code:

---

    rs.Open "SELECT COUNT(serial) FROM users WHERE serial='" & MBSerialNumber & "', cn, 3, 3"";"

---

I am not so sure about this either...

Thanks for your support Kenneth Hobs!

I hope the first problem is done. Now I got this mensage: Access danied for user ***xx (using password: YES).

My password has 7 characters and the ActiveX Data Objects Library is enabled.

I have certified the information for the connection (server, database, user, pass) and it's correct. Do you have any idea what is happening?

Code:

---

Option Explicit
    Dim objs As Object
    Dim obj As Object
    Dim WMI As Object
    Dim sAns As String
    Dim cn As Variant
    Dim rs As Variant
Private Sub Workbook_Open()
    Call MBSerialNumber
    Call ConnectDB
    If rs < 1 Then
        MsgBox ("Data Security failier, This workbook will close")
        ActiveWorkbook.Save
        ActiveWorkbook.Close
    End If
End Sub
Public Function MBSerialNumber() As String
    Set WMI = GetObject("WinMgmts:")
    Set objs = WMI.InstancesOf("Win32_BaseBoard")
    For Each obj In objs
        sAns = sAns & obj.SerialNumber
        If sAns < objs.Count Then sAns = sAns & ","
    Next
    MBSerialNumber = sAns
End Function
Private Sub ConnectDB()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "DRIVER={MySQL ODBC 5.3 ANSI Driver};" & _
        "SERVER=***x;" & _
        "DATABASE=***x;" & _
        "USER=***x;" & _
        "PASSWORD=***x;" & _
        "OPTION=3"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT COUNT(serial) FROM users WHERE serial='" & MBSerialNumber & "', cna, dOpenDynamic, adLockOptimistic"
End Sub

---

Maybe check registry to see what version of ODBC you are using.

This old code might help in other ways.

Code:

---

Sub InsertIntoMySQL()  ' How to add the ADO object:
  ' Tools > References > Microsoft ActiveX Data Objects 2.8 Library
  Dim oConn As ADODB.Connection
  Dim rs As ADODB.RecordSet, rs2 As ADODB.RecordSet
  Dim col As Integer
  Dim wsName As String, dbName As String, strSQL As String
  Dim a As Variant
  Dim c As Range, r As Range, row As Range
 
  wsName = "Film"
  dbName = "film"
 
  On Error GoTo ErrHandler
  Set rs = New ADODB.RecordSet
  Set oConn = New ADODB.Connection
  oConn.Open "DRIVER={MySQL ODBC 5.2 ANSI Driver};" & _
    "SERVER=localhost;" & _
    "DATABASE=Sakila;" & _
    "USER=root;" & _
    "PASSWORD=kenken;" & _
    "Option=3"
 
' Create RecordSet
  Set rs = New ADODB.RecordSet
  With rs
    ' Record locking  ' http://www.utteraccess.com/wiki/index.php?title=Beginners_Guide_To_ODBC
    .CursorLocation = adUseClient
    .CursorType = adOpenStatic
    .LockType = adLockOptimistic
    strSQL = "SELECT * FROM " & dbName
    .Open Source:=strSQL, ActiveConnection:=oConn
 
  '  How to get the field names
    'For col = 0 To .Fields.Count - 1
      'Debug.Print .Fields(col).Name
    'Next col
    'MsgBox .RecordCount
       
    ' How to write the recordset to Excel method 1
    'Range("A1").Offset(1, 0).CopyFromRecordset rs
   
    ' How to write the recordset to an array
    '.MoveFirst
    'a = .GetRows
    ' Below needs tweaking
    'MsgBox "First Record's film_id: " & a(0, 0), , "Second Record's film_id: " & a(0, 1)
    'MsgBox "First Record's title: " & a(1, 0), , "Second Record's title: " & a(1, 1)


    If .RecordCount < 1 Then GoTo EndNow
   
    ' How to get records and field data values
    '.MoveFirst
    'For row = 0 To 0  '(.RecordCount - 1)
    '  For col = 0 To .Fields.Count - 1
    '    Debug.Print "Row: " & row, "Field: " & col, .Fields(col).Name, .Fields(col).Value
    '  Next col
    ' .MoveNext
    'Next row
   
    ' How to iterate each row in a range, add those as new records, _
    and add the field values from the column cells in the row
   
    ' How to add new records and field values from an Excel range
    Set r = Worksheets(wsName).Range("A2:M" & _
      Worksheets(wsName).Range("A" & Rows.Count).End(xlUp).row)
    For Each row In r.Rows
      ' Create RecordSet of Primary Key to Check for Duplicates
      Set rs2 = New ADODB.RecordSet
      With rs2
        ' Record locking  ' http://www.utteraccess.com/wiki/index.php?title=Beginners_Guide_To_ODBC
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
        strSQL = "SELECT film_id FROM " & dbName & " WHERE film_id=" & row.Cells(1).Value2
        .Open Source:=strSQL, ActiveConnection:=oConn
        If rs2.RecordCount >= 1 Then
          Debug.Print row.Cells(1).Value2 & " is a duplicate.  Record was not added."
          GoTo NextRow
        End If
      End With
      .AddNew
      For Each c In row.Cells
      'Debug.Print row.row, c.Column - 1, .Fields(c.Column - 1).Name, c.Value
        ' IF() check to avoid error due to foreign key constraint
        If .Fields(c.Column - 1).Name <> "original_language_id" Then _
        .Fields(c.Column - 1).Value = c.Value 'Fieldnames are 0-index based
      Next c
      .Update
NextRow:
    Next row
  End With  'End rs object referencing
 
ErrHandler:
  If Err.Description <> "" And Err.Source <> "" Then
    MsgBox Err.Description, vbCritical, Err.Source
  End If
 
EndNow:
    Set rs = Nothing
    Set rs2 = Nothing
    oConn.Close
    Set oConn = Nothing
End Sub

---