modfunction.bas

存取检验演示系统.rar 存、取款业务处理 包括某一储户要求存入或取出一定数量存时作记帐处理。 储户管理 包括新建储户、修改储户信息、删除储户。 储蓄管理员作统计处理

Attribute VB_Name = "ModFunction"
Option Explicit
Global g_DSN As String
Global SYS_Cnn As ADODB.Connection
Global g_Password As String

Global gMsgShow As Boolean

'INI变量
Global g_Database As String
Global g_UID As String
Global g_PWD As String
Global g_Server As String
Global g_driver As String
Global gbConnected As Boolean
Global gAccessFileType As String

Global gRAdmin As Boolean
Global gRInput As Boolean
Global gRQuery As Boolean
Global gRExt As Boolean
Global gCurUser As String
Global gFileType As String
Global gFileAccess As String


'用户权限类型
Global Const USER_ADMIN = "0"
Global Const USER_INPUT = "1"
Global Const USER_QUERY = "2"
Global Const USER_DYNADATA = "3"
Global Const USER_GIS = "4"
Global Const USER_IEQUERY = "5"
Global Const USER_IEGIS = "6"
Global Const USER_INTERFACE = "7"
Global Const USER_EXT = "8"



Public Sub ConnectServer()
    gbConnected = True
    If ConnectSysDB Then
        If TestSysTable Then
            frmCheckUser.Show
        Else
            On Error Resume Next
            SYS_Cnn.Close
            gbConnected = False
        End If
    Else
        gbConnected = False
    End If
End Sub

Function ConnectSysDB() As Boolean
Dim adoConnect As String
Dim adoConnect_old As String
Dim g_driver As String
Dim g_Database As String
Dim g_UID As String
Dim vUID As String
Dim g_PWD As String
Dim gsConnectString As String
    adoConnect = ""
    g_driver = "Microsoft Access"
    g_Database = App.Path & "\" & "Test.mdb"
    If g_DSN = "(无)" Or g_DSN = "" Then
        If g_driver = "" Then
            MsgBox "还没有选择有效的数据库驱动程序" & vbCrLf & "请在‘数据源设置’中选择相应的驱动程序", vbInformation, "连接数据库"
            gbConnected = False
            ConnectSysDB = False
            GoTo lbl_End
        End If
    Else
        adoConnect = "DSN=" & g_DSN & ";"
    End If
    adoConnect_old = adoConnect_old & "Driver={" & g_driver & "};"
    adoConnect_old = adoConnect_old & IIf(g_UID = "", "", "User ID=" & vUID & ";")
    adoConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;"
    adoConnect = adoConnect & IIf(g_PWD = "", "", "Jet OLEDB:Database Password=" & g_PWD & ";")
    On Error GoTo Err_File
    If Dir(g_Database, vbNormal) <> "" Then
        adoConnect_old = adoConnect_old & IIf(g_Database = "", "", "DBQ=" & g_Database & ";")
        adoConnect = adoConnect & IIf(g_Database = "", "", "Data Source=" & g_Database & ";")
        adoConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & g_Database & ";Mode=ReadWrite;Jet OLEDB:Database Password =" & g_Password & ";Persist Security Info=False"
        adoConnect_old = adoConnect
    Else
Err_File:
        MsgBox "无法找到指定的数据库!" & vbCrLf & "请检查设置是否正确", vbExclamation + vbOKOnly, "连接数据库"
        gbConnected = False
        ConnectSysDB = False
        GoTo lbl_End
    End If
  On Error GoTo 0
    On Error GoTo err_Connectsysdb
    Set SYS_Cnn = New ADODB.Connection
    SYS_Cnn.ConnectionString = adoConnect
    SYS_Cnn.CommandTimeout = 5
    SYS_Cnn.CursorLocation = adUseClient
    SYS_Cnn.Open
    On Error GoTo 0
    gsConnectString = adoConnect
    gbConnected = True
    ConnectSysDB = True
lbl_End:
     Exit Function
err_Connectsysdb:
    MsgBox "连接数据库出错!" & vbCrLf & "没有打开数据库" & vbCrLf & "检查设置是否正确", , "系统提示"
    Exit Function
End Function



Function TestSysTable() As Boolean
Dim errTimes As Integer
Dim rcSys As New ADODB.Recordset
Dim temName As String
Dim temCaption As String
Dim sSysTableName As String
Dim temVal As Integer
    TestSysTable = False
    temName = "UserLogin"
    temVal = SearchTable(temName)
    If temVal <> 1 Then GoTo err_NotFound
    TestSysTable = True
    Exit Function
err_NotFound:
    MsgBox "系统表：《" & temName & "》不存在,系统无法正常运行！", , "提示系统"
    TestSysTable = False
    Exit Function
err_OpenSysTable:
    MsgBox "数据库系统表打开失败!", , " 系统提示"
End Function


Function SearchTable(vTableName As String) As Integer
Dim rcTest As ADODB.Recordset
    SearchTable = 0
    Set rcTest = New ADODB.Recordset
    On Error GoTo err_NotFound
    rcTest.Open vTableName, SYS_Cnn, adOpenDynamic, adLockOptimistic, adCmdTable
    On Error GoTo 0
    SearchTable = 1
    Exit Function
err_NotFound:
    SearchTable = 0
    Exit Function
End Function

Public Function CanOpenDateBase(fsFilename As String, fsPasswd As String) As Boolean
    On Error GoTo ErrLabel
    Dim sConn As String
    Dim gADO As New ADODB.Connection
    sConn = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & fsFilename & _
            ";Jet OLEDB:Database Password =" & fsPasswd & ";"
    gADO.Open sConn
    If gADO.State > 0 Then
        gADO.Close
    End If
    CanOpenDateBase = True
ErrLabel:
    Err.Clear
    Set gADO = Nothing
End Function