Common procedures
The following reference need to be added to the references of VBAProject.
Microsoft ActiveX Data Objects x.x Library
'Set values of SQL Server
Private Const ServerName As String = "myServerName"
Private Const DatabaseName As String = "myDatabaseName"
Private Const UserID As String = "myID"
Private Const Password As String = "myPassword"
Public Sub OpenConnection(ByRef cn As ADODB.Connection)
cn.ConnectionTimeout = 100 '100 seconds
'# SQL Server Authentication Mode
cn.ConnectionString = "Provider=SQLOLEDB;" & _
"Server=" & ServerName & ";" & _
"Database=" & DatabaseName & ";" & _
"USER ID=" & UserID & ";" & _
"PASSWORD=" & Password & ";"
'# Windows Authentication Mode
'cn.ConnectionString = "Provider=SQLOLEDB;" & _
' "Server=" & ServerName & ";" & _
' "Database=" & DatabaseName & ";" & _
' "Integrated Security=SSPI;"
cn.Open
End Sub
Public Sub OpenRecordsetToRead(ByRef cn As ADODB.Connection, _
ByRef rs As ADODB.Recordset, _
ByVal sql As String)
rs.CursorLocation = adUseServer
rs.CursorType = adOpenForwardOnly
rs.LockType = adLockReadOnly
rs.ActiveConnection = cn
rs.Source = sql
rs.Open
End Sub
Public Sub OpenRecordsetToUpdate(ByRef cn As ADODB.Connection, _
ByRef rs As ADODB.Recordset, _
ByVal sql As String)
rs.CursorLocation = adUseServer
rs.CursorType = adOpenKeyset
rs.LockType = adLockPessimistic
rs.ActiveConnection = cn
rs.Source = sql
rs.Open
End Sub
Public Sub CloseRecordset(ByRef rs As ADODB.Recordset)
If Not rs Is Nothing Then
If rs.State = adStateOpen Then rs.Close
Set rs = Nothing
End If
End Sub
Public Sub CloseConnection(ByRef cn As ADODB.Connection)
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
End Sub
See also Microsoft SQL documentation for ConnectionString of ADODB.Connection
Microsoft OLE DB Provider for SQL Server Overview
Use SQL SELECT statement
Note: The code below uses the common procedures listed at the top of the page.
Public Sub GetRecordset()
On Error GoTo ErrHandler
Dim sql As String
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
sql = "SELECT * FROM SampleTable"
Call OpenConnection(cn)
Call OpenRecordsetToRead(cn, rs, sql)
If rs Is Nothing Or (rs.BOF And rs.EOF) Then
Exit Sub
End If
Do Until rs.EOF
Debug.Print rs.Fields(0).Value 'Show 1st filed of table
Debug.Print rs.Fields(1).Value 'Show 2nd filed of table
rs.MoveNext
Loop
Call CloseRecordset(rs)
Call CloseConnection(cn)
Exit Sub
ErrHandler:
Call CloseRecordset(rs)
Call CloseConnection(cn)
Debug.Print "ErrNumber:" & Err.Number & " " & Err.Description
End Sub
Use SQL statement of INSERT, UPDATE and DELETE
Note: The code below uses the common procedures listed at the top of the page.
Public Sub ExecuteSQL()
On Error GoTo ErrHandler
Dim cn As New ADODB.Connection
Dim sql As String
Call OpenConnection(cn)
sql = "INSERT INTO SampleTable (No, FirstName, LastName) Values(1,'John','Smith')"
'cn.BeginTrans '#Begin transaction
cn.Execute sql
'cn.CommitTrans '#Commit transaction
Call CloseConnection(cn)
Exit Sub
ErrHandler:
'cn.RollbackTrans '#Rollback
Call CloseConnection(cn)
Debug.Print "ErrNumber:" & Err.Number & " " & Err.Description
End Sub
Properties of ADODB.Recordset
ADODB.Recordset has three properties to set.
- CursorLocation
- CursorType
- LockType
See also Microsoft SQL documentation
If set properties are wrong, properties are modified to proper setting automatically.
The following table shows how the set properties are modified. Items written in red are the properties modified.
The table can be output from the following code.
Note: The code below uses the common procedures listed at the top of the page.
Public Sub OutputAdoRsProperty()
On Error GoTo ErrHandler
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim arrayCursorLocation() As Variant
Dim arrayCursorType() As Variant
Dim arrayLockType() As Variant
Dim currentCursorLocation As Variant
Dim currentCursorType As Variant
Dim currentLockType As Variant
Dim fieldsResult As String
Dim currentResult As String
Dim filePathResult As String
arrayCursorLocation = Array(adUseClient, adUseServer)
arrayCursorType = Array(adOpenDynamic, _
adOpenForwardOnly, _
adOpenKeyset, _
adOpenStatic)
arrayLockType = Array(adLockBatchOptimistic, _
adLockOptimistic, _
adLockPessimistic, _
adLockReadOnly)
filePathResult = CurrentProject.Path & "\AdoRsPropertyAbility.csv"
fieldsResult = "Setting Cursor Location," & _
"Setting Cursor Type," & _
"Setting Lock Type," & _
"Actual Cursor Location," & _
"Actual Cursor Type," & _
"Actual Lock Type," & _
"adAddNew," & _
"adApproxPosition," & _
"adBookmark," & _
"adDelete," & _
"adFind," & _
"adHoldRecords," & _
"adIndex," & _
"adMovePrevious," & _
"adNotify," & _
"adResync," & _
"adSeek," & _
"adUpdate," & _
"adUpdateBatch"
Call WriteCurrentResult(filePathResult, fieldsResult)
Dim sql As String
sql = "SELECT * FROM SampleTable"
For Each currentCursorLocation In arrayCursorLocation
For Each currentCursorType In arrayCursorType
For Each currentLockType In arrayLockType
Call OpenConnection(cn)
rs.CursorLocation = currentCursorLocation
rs.CursorType = currentCursorType
rs.LockType = currentLockType
rs.ActiveConnection = cn
rs.Source = sql
rs.Open
'Setting Cursor Location
currentResult = GetCursorLocation(currentCursorLocation) & ","
'Setting Cursor Type
currentResult = currentResult & GetCursorType(currentCursorType) & ","
'Setting Lock Type
currentResult = currentResult & GetLockType(currentLockType) & ","
'Actual Cursor Location
currentResult = currentResult & GetCursorLocation(rs.CursorLocation) & ","
'Actual Cursor Type
currentResult = currentResult & GetCursorType(rs.CursorType) & ","
'Actual Lock Type
currentResult = currentResult & GetLockType(rs.LockType) & ","
'CursorOptionEnum adAddNew
currentResult = currentResult & rs.Supports(adAddNew) & ","
'CursorOptionEnum adApproxPosition
currentResult = currentResult & rs.Supports(adApproxPosition) & ","
'CursorOptionEnum adBookmark
currentResult = currentResult & rs.Supports(adBookmark) & ","
'CursorOptionEnum adDelete
currentResult = currentResult & rs.Supports(adDelete) & ","
'CursorOptionEnum adFind
currentResult = currentResult & rs.Supports(adFind) & ","
'CursorOptionEnum adHoldRecords
currentResult = currentResult & rs.Supports(adHoldRecords) & ","
'CursorOptionEnum adIndex
currentResult = currentResult & rs.Supports(adIndex) & ","
'CursorOptionEnum adMovePrevious
currentResult = currentResult & rs.Supports(adMovePrevious) & ","
'CursorOptionEnum adNotify
currentResult = currentResult & rs.Supports(adNotify) & ","
'CursorOptionEnum adResync
currentResult = currentResult & rs.Supports(adResync) & ","
'CursorOptionEnum adSeek
currentResult = currentResult & rs.Supports(adSeek) & ","
'CursorOptionEnum adUpdate
currentResult = currentResult & rs.Supports(adUpdate) & ","
'CursorOptionEnum adUpdateBatch
currentResult = currentResult & rs.Supports(adUpdateBatch)
Call WriteCurrentResult(filePathResult, currentResult)
Call CloseRecordset(rs)
Call CloseConnection(cn)
Next currentLockType
Next currentCursorType
Next currentCursorLocation
MsgBox "Output has been completed.", vbInformation
Exit Sub
ErrHandler:
Call CloseRecordset(rs)
Call CloseConnection(cn)
Debug.Print "ErrNumber:" & Err.Number & " " & Err.Description
End Sub
Private Function GetCursorLocation(ByVal lngCursorLocation As Long) As String
Select Case lngCursorLocation
Case 2
GetCursorLocation = "adUseServer"
Case 3
GetCursorLocation = "adUseClient"
End Select
End Function
Private Function GetCursorType(ByVal lngCursorType As Long) As String
Select Case lngCursorType
Case 0
GetCursorType = "adOpenForwardOnly"
Case 1
GetCursorType = "adOpenKeyset"
Case 2
GetCursorType = "adOpenDynamic"
Case 3
GetCursorType = "adOpenStatic"
End Select
End Function
Private Function GetLockType(ByVal lngLockType As Long) As String
Select Case lngLockType
Case 1
GetLockType = "adLockReadOnly"
Case 2
GetLockType = "adLockPessimistic"
Case 3
GetLockType = "adLockOptimistic"
Case 4
GetLockType = "adLockBatchOptimistic"
End Select
End Function
Private Sub WriteCurrentResult(ByVal filePathResult As String, _
ByVal currentResult As String)
Open filePathResult For Append As #1
Print #1, currentResult
Close #1
End Sub
Top comments (0)