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