'BeginHelloData
Option Explicit
Dim m_oRecordset As ADODB.Recordset
Dim m_sConnStr As String
Dim m_flgPriceUpdated As Boolean
Private Sub cmdGetData_Click()
GetData
If Not m_oRecordset Is Nothing Then
If m_oRecordset.State = adStateOpen Then
' Set the proper states for the buttons.
cmdGetData.Enabled = False
cmdExamineData.Enabled = True
End If
End If
End Sub
Private Sub cmdExamineData_Click()
ExamineData
End Sub
Private Sub cmdEditData_Click()
EditData
End Sub
Private Sub cmdUpdateData_Click()
UpdateData
' Set the proper states for the buttons.
cmdUpdateData.Enabled = False
End Sub
Private Sub GetData()
On Error GoTo GetDataError
Dim sSQL As String
Dim oConnection1 As ADODB.Connection
m_sConnStr = "Provider='SQLOLEDB';Data Source='MySqlServer';" & _
"Initial Catalog='Northwind';Integrated Security='SSPI';"
' Create and Open the Connection object.
Set oConnection1 = New ADODB.Connection
oConnection1.CursorLocation = adUseClient
oConnection1.Open m_sConnStr
sSQL = "SELECT ProductID, ProductName, CategoryID, UnitPrice " & _
"FROM Products"
' Create and Open the Recordset object.
Set m_oRecordset = New ADODB.Recordset
m_oRecordset.Open sSQL, oConnection1, adOpenStatic, _
adLockBatchOptimistic, adCmdText
m_oRecordset.MarshalOptions = adMarshalModifiedOnly
' Disconnect the Recordset.
Set m_oRecordset.ActiveConnection = Nothing
oConnection1.Close
Set oConnection1 = Nothing
' Bind Recordset to the DataGrid for display.
Set grdDisplay1.DataSource = m_oRecordset
Exit Sub
GetDataError:
If Err <> 0 Then
If oConnection1 Is Nothing Then
HandleErrs "GetData", m_oRecordset.ActiveConnection
Else
HandleErrs "GetData", oConnection1
End If
End If
If Not oConnection1 Is Nothing Then
If oConnection1.State = adStateOpen Then oConnection1.Close
Set oConnection1 = Nothing
End If
End Sub
Private Sub ExamineData()
On Err GoTo ExamineDataErr
Dim iNumRecords As Integer
Dim vBookmark As Variant
iNumRecords = m_oRecordset.RecordCount
DisplayMsg "There are " & CStr(iNumRecords) & _
" records in the current Recordset."
' Loop through the Recordset and print the
' value of the AbsolutePosition property.
DisplayMsg "****** Start AbsolutePosition Loop ******"
Do While Not m_oRecordset.EOF
' Store the bookmark for the 3rd record,
' for demo purposes.
If m_oRecordset.AbsolutePosition = 3 Then _
vBookmark = m_oRecordset.Bookmark
DisplayMsg m_oRecordset.AbsolutePosition
m_oRecordset.MoveNext
Loop
DisplayMsg "****** End AbsolutePosition Loop ******" & vbCrLf
' Use our bookmark to move back to 3rd record.
m_oRecordset.Bookmark = vBookmark
MsgBox vbCr & "Moved back to position " & _
m_oRecordset.AbsolutePosition & " using bookmark.", , _
"Hello Data"
' Display metadata about each field. See WalkFields() sub.
Call WalkFields
' Apply a filter on the type field.
MsgBox "Filtering on type field. (CategoryID=2)", _
vbOKOnly, "Hello Data"
m_oRecordset.Filter = "CategoryID=2"
' Set the proper states for the buttons.
cmdExamineData.Enabled = False
cmdEditData.Enabled = True
Exit Sub
ExamineDataErr:
HandleErrs "ExamineData", m_oRecordset.ActiveConnection
End Sub
Private Sub EditData()
On Error GoTo EditDataErr
'Recordset still filtered on CategoryID=2.
'Increase price by 10% for filtered records.
MsgBox "Increasing unit price by 10%" & vbCr & _
"for all records with CategoryID = 2.", , "Hello Data"
m_oRecordset.MoveFirst
Dim cVal As Currency
Do While Not m_oRecordset.EOF
cVal = m_oRecordset.Fields("UnitPrice").Value
m_oRecordset.Fields("UnitPrice").Value = (cVal * 1.1)
m_oRecordset.MoveNext
Loop
' Set the proper states for the buttons.
cmdEditData.Enabled = False
cmdUpdateData.Enabled = True
Exit Sub
EditDataErr:
HandleErrs "EditData", m_oRecordset.ActiveConnection
End Sub
Private Sub UpdateData()
On Error GoTo UpdateDataErr
Dim oConnection2 As New ADODB.Connection
MsgBox "Removing Filter (adFilterNone).", , "Hello Data"
m_oRecordset.Filter = adFilterNone
Set grdDisplay1.DataSource = Nothing
Set grdDisplay1.DataSource = m_oRecordset
MsgBox "Applying Filter (adFilterPendingRecords).", , "Hello Data"
m_oRecordset.Filter = adFilterPendingRecords
Set grdDisplay1.DataSource = Nothing
Set grdDisplay1.DataSource = m_oRecordset
DisplayMsg "*** PRE-UpdateBatch values for 'UnitPrice' field. ***"
' Display Value, UnderlyingValue, and OriginalValue for
' type field in first record.
If m_oRecordset.Supports(adMovePrevious) Then
m_oRecordset.MoveFirst
DisplayMsg "OriginalValue = " & _
m_oRecordset.Fields("UnitPrice").OriginalValue
DisplayMsg "Value = " & _
m_oRecordset.Fields("UnitPrice").Value
End If
oConnection2.ConnectionString = m_sConnStr
oConnection2.Open
Set m_oRecordset.ActiveConnection = oConnection2
m_oRecordset.UpdateBatch
m_flgPriceUpdated = True
DisplayMsg "*** POST-UpdateBatch values for 'UnitPrice' field ***"
If m_oRecordset.Supports(adMovePrevious) Then
m_oRecordset.MoveFirst
DisplayMsg "OriginalValue = " & _
m_oRecordset.Fields("UnitPrice").OriginalValue
DisplayMsg "Value = " & _
m_oRecordset.Fields("UnitPrice").Value
End If
MsgBox "See value comparisons in txtDisplay.", , _
"Hello Data"
'Clean up
oConnection2.Close
Set oConnection2 = Nothing
Exit Sub
UpdateDataErr:
If Err <> 0 Then
HandleErrs "UpdateData", oConnection2
End If
If Not oConnection2 Is Nothing Then
If oConnection2.State = adStateOpen Then oConnection2.Close
Set oConnection2 = Nothing
End If
End Sub
Private Sub WalkFields()
On Error GoTo WalkFieldsErr
Dim iFldCnt As Integer
Dim oFields As ADODB.Fields
Dim oField As ADODB.Field
Dim sMsg As String
Set oFields = m_oRecordset.Fields
DisplayMsg "****** BEGIN FIELDS WALK ******"
For iFldCnt = 0 To (oFields.Count - 1)
Set oField = oFields(iFldCnt)
sMsg = ""
sMsg = sMsg & oField.Name
sMsg = sMsg & vbTab & "Type: " & GetTypeAsString(oField.Type)
sMsg = sMsg & vbTab & "Defined Size: " & oField.DefinedSize
sMsg = sMsg & vbTab & "Actual Size: " & oField.ActualSize
grdDisplay1.SelStartCol = iFldCnt
grdDisplay1.SelEndCol = iFldCnt
DisplayMsg sMsg
MsgBox sMsg, , "Hello Data"
Next iFldCnt
DisplayMsg "****** END FIELDS WALK ******" & vbCrLf
'Clean up
Set oField = Nothing
Set oFields = Nothing
Exit Sub
WalkFieldsErr:
Set oField = Nothing
Set oFields = Nothing
If Err <> 0 Then
MsgBox Err.Source & "-->" & Err.Description, , "Error"
End If
End Sub
Private Function GetTypeAsString(dtType As ADODB.DataTypeEnum) As String
' To save space, we are only checking for data types
' that we know are present.
Select Case dtType
Case adChar
GetTypeAsString = "adChar"
Case adVarChar
GetTypeAsString = "adVarChar"
Case adVarWChar
GetTypeAsString = "adVarWChar"
Case adCurrency
GetTypeAsString = "adCurrency"
Case adInteger
GetTypeAsString = "adInteger"
End Select
End Function
Private Sub HandleErrs(sSource As String, ByRef m_oConnection As ADODB.Connection)
DisplayMsg "ADO (OLE) ERROR IN " & sSource
DisplayMsg vbTab & "Error: " & Err.Number
DisplayMsg vbTab & "Description: " & Err.Description
DisplayMsg vbTab & "Source: " & Err.Source
If Not m_oConnection Is Nothing Then
If m_oConnection.Errors.Count <> 0 Then
DisplayMsg "PROVIDER ERROR"
Dim oError1 As ADODB.Error
For Each oError1 In m_oConnection.Errors
DisplayMsg vbTab & "Error: " & oError1.Number
DisplayMsg vbTab & "Description: " & oError1.Description
DisplayMsg vbTab & "Source: " & oError1.Source
DisplayMsg vbTab & "Native Error:" & oError1.NativeError
DisplayMsg vbTab & "SQL State: " & oError1.SQLState
Next oError1
m_oConnection.Errors.Clear
Set oError1 = Nothing
End If
End If
MsgBox "Error(s) occurred. See txtDisplay1 for specific information.", , _
"Hello Data"
Err.Clear
End Sub
Private Sub DisplayMsg(sText As String)
txtDisplay1.Text = (txtDisplay1.Text & vbCrLf & sText)
End Sub
Private Sub Form_Resize()
grdDisplay1.Move 100, 700, Me.ScaleWidth - 200, (Me.ScaleHeight - 800) / 2
txtDisplay1.Move 100, grdDisplay1.Top + grdDisplay1.Height + 100, _
Me.ScaleWidth - 200, (Me.ScaleHeight - 1000) / 2
End Sub
Private Sub Form_Load()
cmdGetData.Enabled = True
cmdExamineData.Enabled = False
cmdEditData.Enabled = False
cmdUpdateData.Enabled = False
grdDisplay1.AllowAddNew = False
grdDisplay1.AllowDelete = False
grdDisplay1.AllowUpdate = False
m_flgPriceUpdated = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrHandler:
Dim oConnection3 As New ADODB.Connection
Dim sSQL As String
Dim lAffected As Long
' Undo the changes we've made to the database on the server.
If m_flgPriceUpdated Then
sSQL = "UPDATE Products SET UnitPrice=(UnitPrice/1.1) " & _
"WHERE CategoryID=2"
oConnection3.Open m_sConnStr
oConnection3.Execute sSQL, lAffected, adCmdText
MsgBox "Restored prices for " & CStr(lAffected) & _
" records affected.", , "Hello Data"
End If
'Clean up
oConnection3.Close
Set oConnection3 = Nothing
m_oRecordset.Close
Set m_oRecordset = Nothing
Exit Sub
ErrHandler:
If Not oConnection3 Is Nothing Then
If oConnection3.State = adStateOpen Then oConnection3.Close
Set oConnection3 = Nothing
End If
If Not m_oRecordset Is Nothing Then
If m_oRecordset.State = adStateOpen Then m_oRecordset.Close
Set m_oRecordset = Nothing
End If
End Sub
'EndHelloData