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