Jon Perkins: EXE Articles

Visual Basic.net * SQL Server * Asp.net

Data Object Wizard

This page provides the code for the February 1999 column concerning Data Object Wizards.

Download SQL creation script

The following code is the rsclsPublishers class derived from the Data Object Wizard, as explained in the main article

'=============================================================
'Name: rsclsPublishers (a RecordSet class)
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Contains RecordSet class used as a DataSource class
'for a UserControl object.
'
'Comment: A new RecordSet class is created from the
' main 'Select' RecordSet class.
'This RecordSet class is not connected to the database to allow
'for (1) separate stored procedures for updates, inserts and
'deletes and (2) control of update timing.
'=============================================================
Public SaveMode As EnumSaveMod
'Specifies either the Immediate or Batch mode Save property
' for the ResultSet class.

' The Data Environment object contains all the data
' access commands.
Private de1 As New DataEnvironment1

' Create a new RecordSet class to hold the Foreign Key
' attributes, unless there are no Foreign Key attributes,
' then the Data Environment RecordSet class will be used.
Private WithEvents rs As Recordset
Attribute rs.VB_VarHelpID = -1

'Variant to store system generated Primary Key values.
Private vPKValues() As Variant

'Set the flag when record sets have been initialized.
Private mbDataInitialized As Boolean
'Flag to prohibit running the WillChangeRecord event.
Private mbAddingRecord As Boolean
'Flag to prohibit running the WillChangeRecord event when
' RecordSet class moves after the Delete method runs.
Private mbDeleteInProgress As Boolean

Private bInitComplete As Boolean
'Boolean flag is set when GetDataMember event is complete.
'This event is run when the RecordSet Move method is complete.
Public Event rsMoveComplete()
'This event is run when the RecordSet Delete method is complete.
Public Event DeleteRecordComplete()
'This event is run when the rsUpdate method is complete.
Public Event rsUpdateEvent(vFieldName As Variant)
'This event is run for certain class errors.
Public Event ClassError(sProcedureName As String, oErr _
As ErrObject)

'The external interface Get and Let properties.
Public Property Get au_id() As Variant
  au_id = rs("au_id")
End Property

Public Property Let au_id(vau_id As Variant)
  If IsNull(vau_id) Then
    rs("au_id") = Null
  Else
&  nbsp; rs("au_id") = CStr(vau_id)
  End If
End Property

Public Property Get au_lname() As Variant
  au_lname = rs("au_lname")
End Property

Public Property Let au_lname(vau_lname As Variant)
  If IsNull(vau_lname) Then
    rs("au_lname") = Null
  Else
    rs("au_lname") = CStr(vau_lname)
  End If
End Property

Public Property Get au_fname() As Variant
  au_fname = rs("au_fname")
End Property

Public Property Let au_fname(vau_fname As Variant)
  If IsNull(vau_fname) Then
    rs("au_fname") = Null
  Else
    rs("au_fname") = CStr(vau_fname)
  End If
End Property

Public Property Get phone() As Variant
  phone = rs("phone")
End Property

Public Property Let phone(vphone As Variant)
  If IsNull(vphone) Then
    rs("phone") = Null
  Else
  rs("phone") = CStr(vphone)
  End If
End Property

Public Property Get address() As Variant
  address = rs("address")
End Property

Public Property Let address(vaddress As Variant)
  If IsNull(vaddress) Then
    rs("address") = Null
  Else
    rs("address") = CStr(vaddress)
  End If
End Property

Public Property Get city() As Variant
  city = rs("city")
End Property

Public Property Let city(vcity As Variant)
  If IsNull(vcity) Then
    rs("city") = Null
  Else
    rs("city") = CStr(vcity)
  End If
End Property

Public Property Get state() As Variant
  state = rs("state")
End Property

Public Property Let state(vstate As Variant)
  If IsNull(vstate) Then
    rs("state") = Null
  Else
    rs("state") = CStr(vstate)
  End If
End Property

Public Property Get zip() As Variant
  zip = rs("zip")
End Property

Public Property Let zip(vzip As Variant)
  If IsNull(vzip) Then
    rs("zip") = Null
  Else
    rs("zip") = CStr(vzip)
  End If
End Property

Public Property Get contract() As Variant
  contract = rs("contract")
End Property

Public Property Let contract(vcontract As Variant)
  If IsNull(vcontract) Then
    rs("contract") = Null
  Else
    rs("contract") = CBool(vcontract)
  End If
End Property

'The RecordSet Beginning Of File status.
Public Property Get BOF() As Boolean
  BOF = rs.BOF
End Property

'The RecordSet EndOfFile status.
Public Property Get EOF() As Boolean
  EOF = rs.EOF
End Property

'The RecordSet AbsolutePosition property.
Public Property Let AbsolutePosition(lAbsolutePosition As Long)
  rs.AbsolutePosition = lAbsolutePosition
End Property

Public Property Get AbsolutePosition() As Long
  AbsolutePosition = rs.AbsolutePosition
End Property

'The Foreign Key Descriptor properties.

Private Sub Class_GetDataMember(DataMember As String, _
Data As Object)
'=============================================================
'Name: Class_GetDataMember
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Creates and allows selection of RecordSet classes.
'
'Comment: A new RecordSet is created from the 'Select' RecordSet
' class. Foreign Key Descriptor columns are added to this
' RecordSet class and updated with the Foreign Key Data
' Environment commands mapped to the Select Foreign Key values.
'=============================================================

Dim i As Integer
Dim sLastFieldName As String
Dim sName() As Variant
Dim vValue() As Variant
Dim sNames As Variant
Dim vValues As Variant
Dim oField As Field

On Error GoTo errMSDOG_GDM:

bInitComplete = False

'Choose the RecordSet class based on the DataMember parameter.
Select Case LCase(DataMember)
Case "au_select":
  'Skip initialization if RecordSet class already exists.
  If Not mbDataInitialized Then

    de1.rsau_select.DataMember = ""
    If SaveMode = adImmediate Then
      de1.rsau_select.LockType = adLockOptimistic
    Else
      de1.rsau_select.LockType = adLockBatchOptimistic
    End If

    de1.au_select
    ' Disconnect the RecordSet class to allow (1) stored
    ' procedure access and (2) control over database
    ' update timing.
    Set de1.rsau_select.ActiveConnection = Nothing

    'Data object has been initiallized.
    mbDataInitialized = True

    'If there are no Foreign Key attributes, then just use a
    ' copy of the Data Environment RecordSet class.
    Set rs = de1.rsau_select.Clone
  End If

  'Update all the RecordSet class row status to 'unmodified'.
  rs.UpdateBatch

  'ReDimension the array to hold system generated
  ' Primary Key values.
  ReDim vPKValues(2, 0)

  'Set the Data object to return the Select RecordSet class
  ' to the calling procedure.
  Set Data = rs

  'Close the Data Environment connection
  de1.Connection1.Close

End Select

bInitComplete = True
Exit Sub

errMSDOG_GDM:
RaiseEvent ClassError("GetDataMember", Err)
End Sub

Private Sub Class_Initialize()
'=============================================================
'Name: Class_Initialize
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Standard Class object Initialize event.
'
'Comment:
'=============================================================

'Reset the Initialization variable.
mbDataInitialized = False

End Sub

Private Sub Class_Terminate()
'=============================================================
'Name: Class_Terminate
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Closes Data Environment connections and
' uninitializes objects
'
'Comment:
'=============================================================

'Release the Data Environment and RecordSet objects
Set de1 = Nothing
Set rs = Nothing

End Sub

Private Sub RS_MoveComplete(ByVal adReason As _
ADODB.EventReasonEnum, ByVal pError As ADODB.Error, _
adStatus As ADODB.EventStatusEnum, ByVal pRecordset As _
ADODB.Recordset)
'=============================================================
'Name: RS_MoveComplete
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Standard RecordSet MoveComplete event.
'
'Comment:
'=============================================================

'Exit the subroutine if the BeginningOfFile property is true
If rs.BOF Then
  Exit Sub
End If

'Exit the subroutine if the EndOfFile Property is true
If rs.EOF Then
  Exit Sub
End If

'Raise the rsMoveComplete event
RaiseEvent rsMoveComplete

End Sub

Public Sub Move(lRows As Long)
'=============================================================
'Name: Move
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Move the RecordSet n number of Rows.
'
'Comment:
'=============================================================

On Error GoTo errMove:

rs.Move lRows

Exit Sub

errMove:

End Sub

Public Sub MoveNext()
'=============================================================
'Name: MoveNext
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Move to next record.
'
'Comment:
'=============================================================

If (rs.RecordCount > 0) And (Not rs.EOF) Then
  rs.MoveNext
End If

End Sub

Public Sub MoveFirst()
'=============================================================
'Name: MoveFirst
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Move to first record.
'
'Comment:
'=============================================================

If rs.RecordCount > 0 Then
rs.MoveFirst
End If

End Sub

Public Sub MovePrevious()
'=============================================================
'Name: MovePrevious
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Move to previous record.
'
'Comment:
'=============================================================

If (rs.RecordCount > 0) And (Not rs.BOF) Then
rs.MovePrevious
End If

End Sub

Public Sub MoveLast()
'=============================================================
'Name: MoveLast
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Move to last record.
'
'Comment:
'=============================================================

If rs.RecordCount > 0 Then
rs.MoveLast
End If

End Sub

Public Function ValidateData() As Boolean
'=============================================================
'Name: ValidateData
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: This Function validates the RecordSet class data.
'
'Comment:
'=============================================================

Dim i As Long

ValidateData = False

For i = 0 To rs.Fields.Count - 1
  Select Case LCase(rs.Fields(i).Name)
  Case "au_lname", "au_fname", "phone", "address", "city",
        "state", "zip", "contract"
    If IsEmpty(rs(i)) And Not rs(i).Type = adBoolean Then
      MsgBox rs(i).Name & " error."
      Exit Function
    End If
  End Select
Next i

'Verify the field is not null.
If IsNull(rs("au_id")) Then
  MsgBox "The field ' au_id ' cannot be null."
  Exit Function
End If

'Verify the text field contains text.
If Not IsNull(rs("au_id")) Then
  If Len(Trim(rs("au_id"))) = 0 Then
    MsgBox "The field ' au_id ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("au_lname")) Then
  If Len(Trim(rs("au_lname"))) = 0 Then
    MsgBox "The field ' au_lname ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("au_fname")) Then
  If Len(Trim(rs("au_fname"))) = 0 Then
    MsgBox "The field ' au_fname ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("phone")) Then
  If Len(Trim(rs("phone"))) = 0 Then
    MsgBox "The field ' phone ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("address")) Then
  If Len(Trim(rs("address"))) = 0 Then
    MsgBox "The field ' address ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("city")) Then
  If Len(Trim(rs("city"))) = 0 Then
    MsgBox "The field ' city ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("state")) Then
  If Len(Trim(rs("state"))) = 0 Then
    MsgBox "The field ' state ' does not contain valid text."
    Exit Function
  End If
End If

'Verify the text field contains text.
If Not IsNull(rs("zip")) Then
  If Len(Trim(rs("zip"))) = 0 Then
    MsgBox "The field ' zip ' does not contain valid text."
    Exit Function
  End If
End If

ValidateData = True

End Function

Private Function PutDataInsert() As Boolean
'=============================================================
'Name: PutDataInsert
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Insert current row.
'
'Comment:
'=============================================================

Dim oCommand As Command

On Error GoTo errPutDataInsert

PutDataInsert = False
Set oCommand = de1.Commands("au_insert")

'Workaround for Kagera provider
If LCase(de1.Connection1.Properties("Provider Name")) = _
"msdasql.dll" Then
oCommand.Properties.Item("Force SQL Server Firehose Mode_
cursor").Value = True
End If

'Check for valid data.
If Not ValidateData() Then
  'Raise the ClassError event to detect invalid data.
  RaiseEvent ClassError("Data Validation error.", Err)
  Exit Function
End If

'Execute the command.
oCommand.Execute

PutDataInsert = True
Exit Function

errPutDataInsert:
RaiseEvent ClassError("PutDataInsert", Err)

End Function

Private Function PutDataUpdate() As Boolean
'=============================================================
'Name: PutDataUpdate
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Update current row.
'
'Comment:
'=============================================================

Dim oCommand As Command

On Error GoTo errPutDataUpdate

PutDataUpdate = False
Set oCommand = de1.Commands("au_update")

'Workaround for Kagera provider
If LCase(de1.Connection1.Properties("Provider Name")) = _
"msdasql.dll" Then
oCommand.Properties.Item("Force SQL Server Firehose _
Mode cursor").Value = True
End If

'Check for valid data.
If Not ValidateData() Then
  'Raise the ClassError event to detect invalid data.
  RaiseEvent ClassError("Data Validation error.", Err)
  Exit Function
End If

'Execute the command.
oCommand.Execute

PutDataUpdate = True
Exit Function

errPutDataUpdate:
RaiseEvent ClassError("PutDataUpdate", Err)

End Function

Private Function PutDataDelete() As Boolean
'=============================================================
'Name: PutDataDelete
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Delete current row.
'
'Comment:
'=============================================================

Dim oCommand As Command

On Error GoTo errPutDataDelete

PutDataDelete = False
Set oCommand = de1.Commands("au_delete")

'Workaround for Kagera provider
If LCase(de1.Connection1.Properties("Provider Name")) =
"msdasql.dll" Then
oCommand.Properties.Item("Force SQL Server Firehose _
Mode cursor").Value = True
End If

'Execute the command.
oCommand.Execute

PutDataDelete = True
Exit Function

errPutDataDelete:
RaiseEvent ClassError("PutDataDelete", Err)

End Function

Public Sub UpdateBatch()
'=============================================================
'Name: Update Batch
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Saves all modified records.
'
'Comment:
'=============================================================

On Error GoTo errUpdateBatch:

rs.UpdateBatch
Exit Sub

errUpdateBatch:
RaiseEvent ClassError("UpdateBatch", Err)

End Sub

Public Sub Update()
'=============================================================
'Name: Update
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Saves a single record of the record set.
'
'Comment:
'=============================================================

On Error GoTo errUpdate:

rs.UpdateBatch adAffectCurrent
Exit Sub

errUpdate:
RaiseEvent ClassError("Update", Err)

End Sub

Public Sub AddRecord()
'=============================================================
'Name: AddRecord
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Adds a blank record to the RecordSet class.
'
'Comment: .
'=============================================================

mbAddingRecord = True

With rs
  .AddNew
  .Update
End With

mbAddingRecord = False

rs.MoveLast

End Sub

Public Function MoveToPk(au_id As Variant) As Boolean
'=============================================================
'Name: MoveToPK
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Sets the current RecordSet row with Primary
'Key values
'
'Comment:
'=============================================================

MoveToPk = False

'Move to the first record in the RecordSet class
rs.MoveFirst

Do While Not rs.EOF
  If rs("au_id") = au_id Then
    MoveToPk = True
    Exit Do
  End If
  rs.MoveNext
Loop

End Function

Public Sub rsUpdate(vFieldName As Variant)
'=============================================================
'Name: rsUpdate
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Updates Foreign Key Descriptors and raises rsUpdate
' event
'
'Comment:
'=============================================================

RaiseEvent rsUpdateEvent(vFieldName)

End Sub

Public Sub Delete()
'=============================================================
'Name: Delete
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: This subroutine deletes a single record.
'
'Comment:
'=============================================================

On Error GoTo errDelete

mbDeleteInProgress = True

'Update the current record status to 'unmodified'.
rs.Delete adAffectCurrent

On Error GoTo 0
Me.MovePrevious
mbDeleteInProgress = False

Exit Sub

errDelete:
RaiseEvent ClassError("Delete", Err)

End Sub

Private Sub rs_WillChangeRecord(ByVal adReason As
ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'=============================================================
'Name: rs_WillChangeRecord
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Runs stored procedures to save record.
'
'Comment:
'=============================================================

On Error GoTo errWillChangeRecord

If bInitComplete And (adReason <> adRsnFirstChange) And
    (adReason <> adRsnUndoAddNew) And Not mbAddingRecord Then
  If IsEmpty(rs(0).OriginalValue) Then
    If Not PutDataInsert Then
      adStatus = adStatusCancel
    End If
  Else
    Select Case adReason
    Case adRsnUpdate
      If Not mbDeleteInProgress Then
        If Not PutDataUpdate Then
          adStatus = adStatusCancel
        End If
      End If
    Case adRsnAddNew
      If Not PutDataInsert Then
        adStatus = adStatusCancel
      End If
    Case adRsnDelete
      If Not PutDataDelete Then
        adStatus = adStatusCancel
      End If
      mbDeleteInProgress = True
    End Select
  End If
End If

Exit Sub

errWillChangeRecord:

End Sub

Private Function GetPKValue(vBookMark As Variant, sColName As _
String) As Variant
'=============================================================
'Name: GetPKValue
'
'Author: Microsoft Data Object Wizard
'
'Date: 10/04/1998 19:38
'
'Description: Looks up newly inserted system gen'd PK values.
'
'Comment:
'=============================================================

Dim i As Integer

GetPKValue = rs(sColName)

For i = 1 To UBound(vPKValues, 2)
  If vPKValues(0, i) = vBookMark And LCase(vPKValues(1, i))_
    = LCase(sColName) Then
    GetPKValue = vPKValues(2, i)
    Exit Function
  End If
Next i

End Function

I, Jon Michael Perkins, hereby assert and give notice of my right under section 77 of the Copyright, Designs, and Patents Act 1988 to be identified as the author of the foregoing article.