dbfpublic.bas

VB数据库设计的代码。需要根据自己的数据库再作调整

Attribute VB_Name = "dbfpublic"
'强制变量声明
Option Explicit
'声明对两个Windows API函数的调用
Public Declare Function GetPrivateProfileString Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpAdd As String, ByVal lpFileName As String) As Boolean
'定义用于代表数据连接对象的全局变量
Public Conn As Connection
Public Function GetFromINI(AppName As String, KeyName As String, filename As String) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   GetFromINI = Left(RetStr, GetPrivateProfileString(AppName, ByVal KeyName, "", RetStr, Len(RetStr), filename))
End Function
'ActiveX DLL的启动程序，为DLL初始化时执行
Public Sub Main()
  '定义用于存储欲连接的数据库的类型
  Dim dbftype As String
  '从配置文件中提取欲连接的数据库的类型，并赋给变量dbftype
  dbftype = GetFromINI("数据库信息", "dbftype", App.Path + "\预算管理.ini")
  '调用函数ConnectToDatabase连接指定的数据库
  If ConnectToDatabase(dbftype) = False Then
    Err.Raise vbObjectError + 1, , "连接数据库出错！|" + App.Path + "|"
  End If
End Sub
'连接到数据库
Public Function ConnectToDatabase(DBType As String) As Boolean
  On Error GoTo ERR_CONN
  Set Conn = New Connection
  '设置数据库连接对象Conn的相应属性
  With Conn
     .CursorLocation = adUseClient
     .CommandTimeout = 10
     '判断欲连接的数据库类型，是Access数据库还是SQL Server数据库，
     '并根据数据库的类型设置相应的数据库连接字符串
     If DBType = "0" Then
       ' 要连接到ACCESS数据库
       '定义用于存储Access数据库路径的临时变量
        Dim dbfpath As String
        '从配置文件中提取Access数据库路径，并赋给变量dbfpath
         dbfpath = GetFromINI("数据库信息", "dbfpath", App.Path + "\预算管理.ini ")
       '设置相应的数据库连接字符串
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';" & _
        "Data Source=" & dbfpath
     Else
      ' 要连接到SQL Server数据库
        '定义用于存储服务器名称的临时变量
        Dim ServerName As String
        '定义用于存储数据库名称的临时变量
        Dim DBName As String
        '定义用于存储登录用户名的临时变量
        Dim UserName As String
        '定义用于存储登陆密码的临时变量
        Dim strPwd As String
        
        '从配置文件中提取数据库服务器名称，并赋给变量ServerName
        ServerName = GetFromINI("数据库信息", "server", App.Path + "\预算管理.ini")
        '从配置文件中提取数据库名称，并赋给变量DBName
        DBName = GetFromINI("数据库信息", "database", App.Path + "\预算管理.ini")
        '从配置文件中提取登陆用户名名称，并赋给变量UserName
        UserName = GetFromINI("数据库信息", "loginname", App.Path + "\预算管理.ini")
        '从配置文件中提取登陆密码，并赋给变量strPwd
         strPwd = GetFromINI("数据库信息", "pass", App.Path + "\预算管理.ini ")
         '设置相应的数据库连接字符串
        .ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _
        "User ID=" & UserName & ";Initial Catalog=" & DBName & _
        ";Data Source=" & ServerName & ";pwd=" & strPwd
     End If
     '连接到相应的数据库
     .Open
  End With
  '设置该函数的返回值为true，以表示已经连接到指定的数据库
  ConnectToDatabase = True
  Exit Function
ERR_CONN:
  '设置该函数的返回值为False，以表示不能连接到指定的数据库
  ConnectToDatabase = False
  '显示出错的具体信息
  MsgBox Err.Description
End Function

'替换字符串中的单引号
Public Function RealString(strOrigional) As String
  RealString = Replace(strOrigional, "'", "''")
End Function

'查看指定的数据表中，是否存在指定字段等于指定值的记录（整型）
'在该函数的参数列表中，第一个参数表示表名，第二个参数表示字段名，
'第三个参数表示具体的字段值
Public Function ExistByID(ByVal strTable As String, ByVal strID As String, _
                          ByVal lngID As Long) As Boolean
  '定义数据集对象rs，用于存储执行sql语句后得到的结果集
  Dim rs As Recordset
  '执行sql语句，在指定的数据表中，查找指定字段等于指定值的记录，
  '并用查询结果设置数据集对象rs
  Set rs = Conn.Execute("Select Count(*) from " & strTable & _
                          " where " & strID & "=" & lngID)
  '设置该函数的返回值，以表示指定的数据表中是否存在指定
  '字段等于指定值的记录（整型）
  ExistByID = (rs(0).Value = 1)
End Function
'查看指定的数据表中，是否存在指定字段等于指定值的记录（字符型）
'在该函数的参数列表中，第一个参数表示表名，第二个参数表示字段名，
'第三个参数表示具体的字段值
Public Function ExistByName(ByVal strTable As String, ByVal strFieldName _
                           As String, ByVal strName As String) As Boolean
 '定义数据集对象rs，用于存储执行sql语句后得到的结果集
  Dim rs As Recordset
   '执行sql语句，在指定的数据表中，查找指定字段等于指定值的记录，
  '并用查询结果设置数据集对象rs
  Set rs = Conn.Execute("Select Count(*) from " & strTable & " where " & _
                          strFieldName & "='" & strName & "'")
  '设置该函数的返回值，以表示指定的数据表中是否存在指定
  '字段等于指定值的记录（字符型）
  ExistByName = (rs(0).Value = 1)
End Function
'以上两个函数实际上可以合并，本程序中为了说明问题，故而分开
'在指定的数据表中，根据给定的主键值，获得指定字段的值
'在该函数的参数列表中，第一个参数表示表名，第二个参数表示主键字段名，
'第三个参数表示主键字段值，第四个参数表示要获取值的字段名
Public Function GetValueByID(ByVal strTable As String, ByVal strID As String, _
                  ByVal lngID As Long, ByVal strValueField As String) As String
 '定义数据集对象rs，用于存储执行sql语句后得到的结果集
  Dim rs As Recordset
 '执行sql语句，在指定的数据表中，根据给定的主键值，获得指定字段的值，
  '并用执行结果设置数据集对象rs
  Set rs = Conn.Execute("Select " & strValueField & " from " & strTable & _
                          " where " & strID & "=" & lngID)
  '设置该函数的返回值，以返回要得到的指定字段的值
  '如果没有找到该字段值，则返回空值
  If rs.RecordCount = 1 Then
    GetValueByID = rs(0).Value
  Else
    GetValueByID = ""
  End If
  Set rs = Nothing
End Function

'执行一条无返回结果的 SQL 语句
'在该函数的参数列表中，第一个参数表示要执行的sql语句，第二个参数
'表示sql语句执行错误时，返回的错误信息
Public Function RunSql(strSQL As String, ByRef strErrMsg As String) As Boolean
  On Error Resume Next
  '执行strSQL代表的SQL语句
  Conn.Execute strSQL
  '根据是否出错，返回给调用者相应的信息
  If Err.Number = 0 Then
    '设置该函数的返回值为true，以表示sql语句得到正确执行
    RunSql = True
  Else
    'sql语句没有得到正确执行，得到相应的错误信息
    strErrMsg = Err.Description
    '设置该函数的返回值为false，以表示sql语句没有得到正确执行
    RunSql = False
  End If
End Function
'执行一条有返回结果的 SQL 语句
'在该函数的参数列表中，第一个参数表示要执行的sql语句，第二个参数
'表示sql语句执行错误时，返回的错误信息，第三个参数表示返回的数据集对象
Public Function GetRecordset(strSQL As String, ByRef strErrMsg As String, _
                            ByRef rs As Recordset) As Boolean
  On Error Resume Next
  '执行SQL语句,并用返回的结果集设置数据集对象rs
  Set rs = Conn.Execute(strSQL)
  '根据是否出错，返回给调用者相应的信息
  If Err.Number = 0 Then
    '设置该函数的返回值为true，以表示sql语句得到正确执行
    GetRecordset = True
  Else
    'sql语句没有得到正确执行，得到相应的错误信息
    strErrMsg = Err.Description
    '设置该函数的返回值为false，以表示sql语句没有得到正确执行
    GetRecordset = False
  End If
End Function