clsaccessdb.cls

计算机网络与通信的知识

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsAccessDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'============================================================================
'||                                                                        ||
'||                   数据库操作 类 模块  (独立存在，通用)                 ||
'||                         (在服务器端用)                                 ||
'||                                                                        ||
'||   该类作为较大型C/S数据库系统的数据服务层。它的任务是直接和服务器数据  ||
'|| 库进行操作，将操作的结果返回给指令处理对象。                           ||
'||                                                                        ||
'============================================================================

Option Explicit
    '本系统只用到一个数据库，若系统较大，可继续定义DB_NAME_2，...
Private Const DB_NAME_1 = "sys.mdb"
    '数据库操作执行返回码（成功 或 失败）
Private Const EXE_SUCCESS = "OK"
Private Const EXE_FAILURE = "NO"
    '记录集转换为字符串的最大长度（String变长数据类型的最大容量）
Private Const MAXLEN_STR = 2000000000

    '记录集中的分割符
Dim str_FIELD_DIV_RECORD  As String   '字段和记录内容的分割符
Dim str_FDRD_DIV     As String       '字段名之间 或 记录之间的分割符


'###########################################################
'     数据库操作类的一个方法
'         （该方法一定要在引用该类后最先调用）
'  功能描述：
'      设置数据库记录集字符串的分隔符
'  入口参数:
'     strFdRd       字符串中字段名称之间、记录内容各字段之间的分隔符
'     strFdDivRst   字符串中字段名称和记录内容的分隔符
'###########################################################
Public Sub SetFdDivRstCode(ByVal strFdRd As String, _
                           ByVal strFdDivRst As String)
     str_FDRD_DIV = strFdRd
     str_FIELD_DIV_RECORD = strFdDivRst
End Sub


'###########################################################
'     数据库操作类的核心方法
'  功能描述：
'      根据命令操作码执行命令，执行完毕返回成功与否的标志或
'   查询结果字符串。
'  入口参数:
'      intDBNameNum        要操作的数据库序号
'      strCommandOptCode   命令操作码
'      strCommandData      命令操作数（SQL语句）
'  返回值：
'      命令操作码         解释                    返回值
'        SEARCH     查找符合某条件的记录       成功与否的标志
'        BROWSE     浏览符合某条件的记录集     记录集字符串
'        ADDNEW     数据库新增记录             成功与否的标志
'        DELETE     数据库新增记录             成功与否的标志
'        UPDATE     数据库新增记录             成功与否的标志
'###########################################################
Public Function ExeDataBaseAccess(ByVal intDBNameNum As Integer, _
                                  ByVal strCommandOptCode As String, _
                                  ByVal strCommandData As String) As String
Dim obtDBs As Database
Dim strDBsPathName As String
Dim obtRstTp As Recordset
Dim obtQdfTp As QueryDef
Dim strResult As String

Select Case intDBNameNum
    Case 1
        strDBsPathName = App.Path + "\" + DB_NAME_1   '获取数据库文件存放的全路径名称
End Select
On Error GoTo OPEN_DB_ERROR
Set obtDBs = OpenDatabase(strDBsPathName)
If StrComp(strCommandOptCode, "BROWSE", vbTextCompare) = 0 Or _
   StrComp(strCommandOptCode, "SEARCH", vbTextCompare) = 0 Then
        '执行查询操作，建立临时查询表
    On Error GoTo EXE_ERROR
    Set obtQdfTp = obtDBs.CreateQueryDef("", strCommandData)
    Set obtRstTp = obtQdfTp.OpenRecordset
    If StrComp(strCommandOptCode, "SEARCH", vbTextCompare) = 0 Then
        If obtRstTp.EOF Then   '如果是查找某条记录，则返回成功或失败
            strResult = EXE_FAILURE
        Else
            strResult = EXE_SUCCESS
        End If
    Else
        '如果是浏览记录，则无条件返回记录内容（空记录返回字段列表）
        strResult = DBsRstToStr(obtRstTp)
    End If
    obtRstTp.Close
    obtQdfTp.Close   '以""命名的临时查询表在关闭后，自动在数据库中删除
    obtDBs.Close
    ExeDataBaseAccess = strResult
Else
    On Error GoTo EXE_ERROR
    obtDBs.Execute strCommandData, dbFailOnError   '新增、删除、更改记录
    strResult = EXE_SUCCESS
    obtDBs.Close
    ExeDataBaseAccess = strResult
End If
Exit Function
EXE_ERROR:
    obtDBs.Close
OPEN_DB_ERROR:
    ExeDataBaseAccess = EXE_FAILURE
End Function
'=====================================================
'      将一个记录集中的记录顺序转为字符串返回
'字段名称之间和记录内容中各字段之间用FDRD_DIV分隔
'字段和记录内容之间用FIELD_DIV_RECORD分隔
'若转换后的字符串长度大于20亿，只返回长度<=20亿的字符
'将字符串还原为记录的函数见modWordProcess标准模块
'=====================================================
Private Function DBsRstToStr(ByVal obtRstTp As Recordset) As String
Dim strTp As String
Dim intTp As Integer, intFdCt As Integer
Dim blnMaxLen As Boolean


strTp = ""
intFdCt = obtRstTp.Fields.Count - 1
For intTp = 0 To intFdCt
    strTp = strTp + obtRstTp.Fields(intTp).Name
    If intTp <> intFdCt Then
        strTp = strTp + str_FDRD_DIV
    Else
        strTp = strTp + str_FIELD_DIV_RECORD
    End If
Next intTp
obtRstTp.MoveLast
obtRstTp.MoveFirst
blnMaxLen = False
While Not obtRstTp.EOF And Not blnMaxLen
    For intTp = 0 To intFdCt
        strTp = strTp + CStr(obtRstTp.Fields(intTp)) + str_FDRD_DIV
    Next intTp
    If Len(strTp) >= MAXLEN_STR Then blnMaxLen = True
    If Not obtRstTp.EOF Then obtRstTp.MoveNext
Wend
strTp = Mid(strTp, 1, Len(strTp) - 1)  '去掉末端分割字符
DBsRstToStr = strTp
End Function
'################################################
' 返回新注册用户的用户号（ICQ专用）
'################################################
Public Function GetNewAccount() As Long
Dim obtDBs As Database
Dim strDBsPathName As String
Dim obtRstTp As Recordset
Dim lngTp As Long

strDBsPathName = App.Path + "\" + DB_NAME_1   '获取数据库文件存放的全路径名称
Set obtDBs = OpenDatabase(strDBsPathName)
Set obtRstTp = obtDBs.OpenRecordset("accountnumber")
lngTp = obtRstTp.Fields("number")
lngTp = lngTp + 1
obtRstTp.Edit
obtRstTp.Fields("number") = lngTp
obtRstTp.Update
Set obtRstTp = Nothing
Set obtDBs = Nothing
GetNewAccount = lngTp
End Function
'################################################
' 根据用户号得到呢称（ICQ专用）
'################################################
Public Function GetName(ByVal lngAccount As Long) As String
Dim obtDBs As Database
Dim strDBsPathName As String
Dim obtRstTp As Recordset
Dim obtQdfTp As QueryDef
Dim strTp As String

strDBsPathName = App.Path + "\" + DB_NAME_1   '获取数据库文件存放的全路径名称
Set obtDBs = OpenDatabase(strDBsPathName)
Set obtQdfTp = obtDBs.CreateQueryDef("", "SELECT name FROM user WHERE account = '" + CStr(lngAccount) + "'")
Set obtRstTp = obtQdfTp.OpenRecordset
strTp = obtRstTp.Fields("name")
Set obtRstTp = Nothing
Set obtQdfTp = Nothing
Set obtDBs = Nothing
GetName = strTp
End Function