ADO HelloData Code 'BeginHelloData Option Explicit Dim m_oRecordset1 As ADODB.Recordset Dim m_sConnStr As String Dim m_flgPriceUpdated As Boolean Private Sub cmdEditData_Click() EditData End Sub Private Sub cmdExamineData_Click() ExamineData End Sub Private Sub cmdGetData_Click() GetData End Sub Private Sub cmdUpdateData_Click() UpdateData End Sub Private Sub GetData() Dim sSQL As String Dim oConnection1 As ADODB.Connection m_sConnStr = "Provider=SQLOLEDB;Data Source=MySrvr;" & _ "Initial Catalog=Northwind;User Id=MyId;Password=123aBc;" On Error GoTo GetDataError ' 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 Product" ' Create and Open the Recordset object. Set m_oRecordset1 = New ADODB.Recordset m_oRecordset1.Open sSQL, oConnection1, adOpenStatic, _ adLockBatchOptimistic, adCmdText m_oRecordset1.MarshalOptions = adMarshalModifiedOnly ' Disconnect the Recordset. Set m_oRecordset1.ActiveConnection = Nothing oConnection1.Close Set oConnection1 = Nothing ' Bind Recordset to the DataGrid for display. Set grdDisplay1.DataSource = m_oRecordset1 Exit Sub GetDataError: If oConnection1 Is Nothing Then HandleErrs "GetData", m_oRecordset1.ActiveConnection Else HandleErrs "GetData", oConnection1 End If End Sub Private Sub ExamineData() Dim iNumRecords As Integer Dim vBookmark As Variant On Err GoTo ExamineDataErr iNumRecords = m_oRecordset1.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_oRecordset1.EOF ' Store the bookmark for the 3rd record, ' for demo purposes. If m_oRecordset1.AbsolutePosition = 3 Then _ vBookmark = m_oRecordset1.Bookmark DisplayMsg m_oRecordset1.AbsolutePosition m_oRecordset1.MoveNext Loop DisplayMsg "****** End AbsolutePosition Loop ******" & vbCrLf ' Use our bookmark to move back to 3rd record. m_oRecordset1.Bookmark = vBookmark MsgBox vbCr & "Moved back to position " & _ m_oRecordset1.AbsolutePosition & " using bookmark.", , _ "Hello Data" ' Display meta-data 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_oRecordset1.Filter = "CategoryID=2" Exit Sub ExamineDataErr: HandleErrs "ExamineData", m_oRecordset1.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_oRecordset1.MoveFirst Dim cVal As Currency Do While Not m_oRecordset1.EOF cVal = m_oRecordset1.Fields("UnitPrice").Value m_oRecordset1.Fields("UnitPrice").Value = (cVal * 1.1) m_oRecordset1.MoveNext Loop Exit Sub EditDataErr: HandleErrs "EditData", m_oRecordset1.ActiveConnection End Sub Private Sub UpdateData() Dim oConnection2 As New ADODB.Connection On Error GoTo UpdateDataErr MsgBox "Removing Filter (adFilterNone).", , "Hello Data" m_oRecordset1.Filter = adFilterNone Set grdDisplay1.DataSource = Nothing Set grdDisplay1.DataSource = m_oRecordset1 MsgBox "Applying Filter (adFilterPendingRecords).", , "Hello Data" m_oRecordset1.Filter = adFilterPendingRecords Set grdDisplay1.DataSource = Nothing Set grdDisplay1.DataSource = m_oRecordset1 DisplayMsg "*** PRE-UpdateBatch values for 'UnitPrice' field. ***" ' Display Value, UnderlyingValue, and OriginalValue for ' type field in first record. If m_oRecordset1.Supports(adMovePrevious) Then m_oRecordset1.MoveFirst DisplayMsg "OriginalValue = " & _ m_oRecordset1.Fields("UnitPrice").OriginalValue DisplayMsg "Value = " & _ m_oRecordset1.Fields("UnitPrice").Value End If oConnection2.ConnectionString = m_sConnStr oConnection2.Open Set m_oRecordset1.ActiveConnection = oConnection2 m_oRecordset1.UpdateBatch m_flgPriceUpdated = True DisplayMsg "*** POST-UpdateBatch values for 'UnitPrice' field ***" If m_oRecordset1.Supports(adMovePrevious) Then m_oRecordset1.MoveFirst DisplayMsg "OriginalValue = " & _ m_oRecordset1.Fields("UnitPrice").OriginalValue DisplayMsg "Value = " & _ m_oRecordset1.Fields("UnitPrice").Value End If MsgBox "See value comparisons in txtDisplay.", , _ "Hello Data" Exit Sub UpdateDataErr: HandleErrs "UpdateData", oConnection2 End Sub Private Sub WalkFields() Dim iFldCnt As Integer Dim oFields As ADODB.Fields Dim oField As ADODB.Field Dim sMsg As String Set oFields = m_oRecordset1.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 Set oField = Nothing Set oFields = Nothing 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 adCurrency GetTypeAsString = "adCurrency" Case adInteger GetTypeAsString = "adInteger" End Select End Function Private Sub Form_Load() grdDisplay1.AllowAddNew = False grdDisplay1.AllowDelete = False grdDisplay1.AllowUpdate = False m_flgPriceUpdated = False End Sub Private Sub Form_Unload(Cancel As Integer) Dim oConnection3 As New ADODB.Connection Dim sSQL As String Dim lAffected As Long If Not m_oRecordset1 Is Nothing Then Set m_oRecordset1 = Nothing End If ' 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 If oConnection3.State = adStateOpen Then oConnection3.Close Set oConnection3 = Nothing End If End Sub Private Sub HandleErrs(sSource As String, ByRef oConnection1 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 oConnection1 Is Nothing Then If oConnection1.Errors.Count <> 0 Then DisplayMsg "PROVIDER ERROR" Dim oError1 As ADODB.Error For Each oError1 In oConnection1.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 oConnection1.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 'EndHelloData Built on Friday, November 17, 2000 © 1999 Microsoft Corporation. All rights reserved. Terms of use. ado260