cdataaccessobject.cls

Decision 算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 1  'vbDataSource
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDataAccessObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Public ConnectionObject As ADODB.Connection
Public ConnectionString As String

Dim WithEvents adoPrimaryRS As ADODB.Recordset
Attribute adoPrimaryRS.VB_VarHelpID = -1
Private DoingRequery As Boolean
Public Event MoveComplete()
'local variable(s) to hold property value(s)
Private mvarFieldNames() As Variant 'local copy

Private Sub Class_Initialize()
    
  Dim db As ADODB.Connection
    
  Set adoPrimaryRS = New Recordset
  
  
  If (DataMiningServer.UseView = XMLView) Then
        
        'Open and display the contents of an XML file
        adoPrimaryRS.Open DataMiningServer.ReadFromXMLPath
        
        DataMembers.Add "Primary"
        
  ElseIf (DataMiningServer.UseView = SQLView) Then
        
        'Open and display the data from a SQL statement
        If (ConnectionObject Is Nothing) Then
            Set ConnectionObject = New ADODB.Connection
        End If
        
        
        ConnectionObject.Open DataMiningServer.ConnectionStringUsed
      
        Set db = ConnectionObject
  
        db.CursorLocation = adUseClient
     
        adoPrimaryRS.Open DataMiningServer.SQLStatementUsed, db, adOpenStatic, adLockOptimistic
        
        DataMembers.Add "Primary"
    
  End If
 
   
End Sub

Public Function ExecuteSQL(QueryString As String, Connect As String, _
                                    Conn As Connection, _
                                    CursorLocation As ADODB.CursorLocationEnum, _
                                    CursorType As ADODB.CursorTypeEnum, _
                                    LockType As ADODB.LockTypeEnum, _
                                    Optional ByRef ReturnRecordset As ADODB.Recordset, _
                                    Optional ByRef ReturnArray As Variant) As Boolean
                                    
                                    
'Purpose:   Executes a SQL string on the server and returns the results
On Error GoTo ErrorHandler
    
    
    'If there is no valid connection, create a new ado connection
    If (Conn Is Nothing) Then
        Set Conn = New Connection
        
        Conn.CursorLocation = CursorLocation
        Conn.Open Connect
    End If
    
                                                   
    If (ReturnRecordset Is Nothing) Then
       Set ReturnRecordset = New Recordset
    End If
        
        
    ReturnRecordset.Open QueryString, Conn, CursorType, LockType
    
        
Exit_ErrorHandler:
    Exit Function
    
ErrorHandler:
    Resume Exit_ErrorHandler
    
End Function

Public Function WriteToXML(rstSchema As ADODB.Recordset, strPath As String) As Boolean
'Writes the rules created in XML Format

On Error GoTo ErrorHandler


    rstSchema.Save strPath, adPersistXML


Exit_ErrorHandler:
    Exit Function
    
    
ErrorHandler:

     ErrorManager.ErrorHandler Err, "cDataAccessObject.WriteToXML"
    Resume Exit_ErrorHandler

End Function

Private Sub Class_GetDataMember(DataMember As String, Data As Object)
  Select Case DataMember
  Case "Primary"
    Set Data = adoPrimaryRS
  End Select
End Sub

Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  RaiseEvent MoveComplete
End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'This is where you put validation code
  'This event gets called when the following actions occur
  Dim bCancel As Boolean
  Select Case adReason
  Case adRsnAddNew
  Case adRsnClose
  Case adRsnDelete
  Case adRsnFirstChange
  Case adRsnMove
  Case adRsnRequery
  Case adRsnResynch
  Case adRsnUndoAddNew
  Case adRsnUndoDelete
  Case adRsnUndoUpdate
  Case adRsnUpdate
  End Select

  If bCancel Then adStatus = adStatusCancel
End Sub

Public Property Get EditingRecord() As Boolean
  EditingRecord = (adoPrimaryRS.EditMode <> adEditNone)
End Property

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

Public Sub AddNew()
  adoPrimaryRS.AddNew
End Sub

Public Sub Delete()
  adoPrimaryRS.Delete
    MoveNext
End Sub

Public Sub Requery()
  adoPrimaryRS.Requery
  DataMemberChanged "Primary"
End Sub

Public Sub Update()
  With adoPrimaryRS
    .UpdateBatch adAffectAll
    If .EditMode = adEditAdd Then
      MoveLast
    End If
  End With
End Sub

Public Sub Cancel()
  With adoPrimaryRS
    .CancelUpdate
    If .EditMode = adEditAdd Then
      MoveFirst
    End If
  End With
End Sub

Public Sub MoveFirst()
  adoPrimaryRS.MoveFirst
End Sub

Public Sub MoveLast()
  adoPrimaryRS.MoveLast
End Sub

Public Sub MoveNext()
  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    'moved off the end so go back
    adoPrimaryRS.MoveLast
  End If
End Sub

Public Sub MovePrevious()
  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    'moved off the end so go back
    adoPrimaryRS.MoveFirst
  End If
End Sub

Private Property Let FieldNames(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.FieldNames = 5
    'mvarFieldNames = vData
End Property

Private Property Set FieldNames(ByVal vData As Variant)
'used when assigning an Object to the property, on the left side of a Set statement.
'Syntax: Set x.FieldNames = Form1
    'Set mvarFieldNames = vData
End Property

Public Property Get FieldNames() As Variant
'Lists all the fieldnames in the recordset

Dim fld As ADODB.Field
Dim lngCount As Long

For Each fld In adoPrimaryRS.Fields

    lngCount = lngCount + 1
    ReDim Preserve mvarFieldNames(0 To lngCount)

    'The first member of this array will keep a count
    'of the number of fields
    mvarFieldNames(0) = (lngCount)
    
    mvarFieldNames(lngCount) = fld.Name
    
    
Next fld

FieldNames = mvarFieldNames()


End Property