HelloData Code

'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 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_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