clsdatabase.cls

新收集的客户管理软件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDataBase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'欢迎你下载使用本代码，本份代码由程序太平洋提供下载学习之用
'声明:
'1.本站所有代码的版权归原作者所有，如果你使用了在本站下载的源代码
'  引起的一切纠纷(后果)与本站无关,请您尊重原作者的劳动成果！
'2.若本站在代码上有侵权之处请您与站长联系，站长会及时更正。
'网站：http://www.daima.com.cn
'程序太平洋：http://www.5ivb.net
'Email:[e-mail]
'CopyRight 2001-2005 By WangFeng
'整理时间：2004-12-14 23:41:45

''*************************************************************************
''**模 块 名：clsDataBase
''**说    明：多易工作室
''**创 建 人：邬浩杰
''**日    期：2004-12-14
''**修 改 人：
''**日    期：
''**描    述：
''**版    本：V1.0.0
''*************************************************************************
'数据库操作类
Option Explicit
Dim WithEvents RS As ADODB.Recordset
Attribute RS.VB_VarHelpID = -1
Dim Cnn1 As ADODB.Connection
Dim strDatasrc As String
Dim mbOpened As Boolean

Private Sub Class_Initialize()
    strDatasrc = App.Path & "\" & DATABASE_FILE_NAME
End Sub

'打开数据库
Public Function OpenDB(strDataTable As String) As Boolean

    '   Dim cnn1 As ADODB.Connection
    '   Dim rs As ADODB.Recordset
    Dim strCnn As String
    Dim varDate As Variant
    On Error GoTo pserror
    ' 打开连接。
    strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDatasrc & "; "
    Set Cnn1 = New ADODB.Connection
    Cnn1.Open strCnn

    ' 打开雇员表。
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenKeyset
    RS.LockType = adLockOptimistic
    RS.Open strDataTable, Cnn1, , , adCmdTable
    OpenDB = True
    mbOpened = True
    Exit Function
pserror:
    OpenDB = False
    mbOpened = False
End Function

'关闭数据库
Public Function CloseDB()
    If Not (RS Is Nothing) Then
        RS.Close
        Cnn1.Close
    End If
    mbOpened = False
End Function
'取得记录的个数
Public Function GetRecordCount()
    Dim intRecCount As Integer
    MoveLast
    intRecCount = RS.RecordCount
    MoveFirst
    GetRecordCount = intRecCount
End Function

Public Function GetRecord(strTitle As String) As Variant
    'Debug.Print RS.AbsolutePosition
    On Error GoTo psErr
    Dim Temp
    Temp = RS(strTitle)
    '经过下面的转化，如果temp是null的话，使temp变成空字符串。
    Temp = " " & Temp
    Temp = LTrim(Temp)
    GetRecord = Temp
    Exit Function
psErr:
    Debug.Print "GetRecord" & Err.Description
    MsgBox "数据库已破坏，请修复后使用", vbExclamation
    End
End Function
Public Function SetRecord(strTitle As String, varData) As Variant
    On Error GoTo psErr
    RS(strTitle) = varData
    Exit Function
psErr:
    Debug.Print "SetRecord:" & Err.Description
    'Debug.Print RS.AbsolutePosition
End Function
Public Sub Update()
    With RS
        .UpdateBatch adAffectAll
        If GetRecordCount > 0 Then
            If .EditMode = adEditAdd Then
                MoveLast
            End If
        End If
    End With
End Sub
Public Sub AddNew()
    RS.AddNew
End Sub
Public Sub Delete()
    If RS.RecordCount > 0 Then
        RS.Delete
    End If
End Sub

'''''''''''''''''''''''''''''''''''''''''''''
'函数（或过程）说明：移动RecordSet游标
'参数说明：lngPosition为RecordSet游标要移至的目标位置
'返回：无
'''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Move(lngPosition As Long)
    If lngPosition > 0 Then
        Dim lngDisplacement As Long                        '相对第一个记录的位移
        lngDisplacement = lngPosition - 1                  '位移等于目标位置减一
        Call RS.Move(lngDisplacement, adBookmarkFirst)     '从首记录开始
        ' 捕获 BOF 或 EOF。
        Debug.Print RS.AbsolutePosition
        If RS.EOF And RS.RecordCount > 0 Then
            MoveLast
        End If
        If RS.BOF And RS.RecordCount > 0 Then
            '已到最后返回
            MoveFirst
        End If
    End If

    'Debug.Print RS.AbsolutePosition
End Sub
Public Sub MoveFirst()
    If RS.RecordCount > 0 Then
        RS.MoveFirst
    End If
End Sub
Public Sub MoveLast()
    If RS.RecordCount > 0 Then
        RS.MoveLast
    End If
End Sub

Public Sub MoveNext()
    If Not RS.EOF Then RS.MoveNext
    ' 捕获  EOF。
    If RS.EOF And RS.RecordCount > 0 Then
        RS.MoveLast
    End If
End Sub

Public Sub MovePrevious()
    If Not RS.BOF Then RS.MovePrevious
    ' 捕获 BOF。
    If RS.BOF And RS.RecordCount > 0 Then
        '已到最后返回
        RS.MoveFirst
    End If
End Sub
Public Sub CancelUpdate()
    RS.CancelUpdate
End Sub

Public Property Get Error() As ADODB.Error
    Set Error = Cnn1.Errors.Item(0)
End Property
Public Property Get EOF() As Boolean
    On Error GoTo psErr
    EOF = RS.EOF
    Exit Function
psErr:
    Debug.Print Err.Description
End Property
Public Property Get BOF() As Boolean
    On Error GoTo psErr
    BOF = RS.BOF
    Exit Function
psErr:
    Debug.Print Err.Description
End Property
Public Function FilterField(strField As String, strFilter As String, strMode As String) As ADODB.Recordset
    On Error GoTo psErr
    ' 在指定的记录集对象上设置筛选操作并打开一个新的记录集对象。
    RS.Filter = strField & " " & strMode & " '" & strFilter & "'"
    Set FilterField = RS
    Exit Function
psErr:
    Debug.Print Err.Description
End Function
Public Function FilterString(strFilter As String) As ADODB.Recordset

    ' 在指定的记录集对象上设置筛选操作并打开一个新的记录集对象。
    RS.Filter = strFilter
    Set FilterString = RS
End Function

Public Function CancelFilter()
    RS.Filter = adFilterNone
End Function

Public Property Get IsOpened() As Boolean
    IsOpened = mbOpened
End Property