HelloData-Code

Gilt für: Access 2013, Office 2013

 
'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