PDA

View Full Version : Error connecting to MySQL using VBA (3709 error)



matheus
02-05-2017, 02:25 PM
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.




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

matheus
02-05-2017, 05:20 PM
follow a excel exemplo with error.

Kenneth Hobs
02-05-2017, 06:42 PM
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.

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

I am not so sure about this either...

matheus
02-06-2017, 12:13 PM
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?



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

Kenneth Hobs
02-06-2017, 12:55 PM
Maybe check registry to see what version of ODBC you are using.

This old code might help in other ways.

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