modmain.bas

本人用VB 6.0和ACCESS编写的水费管理系统

Attribute VB_Name = "modMain"
Option Explicit
Public OFFCAT As IAgentCtlCharacter
Public OFFCATRequest As IAgentCtlRequest
Public fMainForm As frmMain
Public FirstUse As Boolean
Public OperatorNum As Integer, OperatorNameNum As Integer, _
       OperatorName1 As String, OperatorName2 As String
Dim strName() As String, strType() As Long, strSize() As Long
Dim fso As New FileSystemObject
Public Const RegionNumber = 12

Sub Main()
    frmSplash.Show vbModal              '显示启动屏幕
    frmSplash.Refresh
    IniPathX
    '是否第一次使用
    Dim strAppName As String
    strAppName = App.Path + "\权限表.mdb"
    Dim fso As New FileSystemObject
    If Not fso.FileExists(strAppName) Then
        FirstUse = True
    End If
    If Not FirstUse Then
        Dim fLogin As New frmLogin
        fLogin.Show vbModal
        If Not fLogin.LoginSucceeded Then
            '登录失败，退出应用程序
            End
        End If
        Unload fLogin
    End If
    
    Set fMainForm = New frmMain         '显示主窗体
    Load fMainForm
    fMainForm.Show
End Sub
Public Sub IniPathX()

    ' Change the IniPath property to point to a different
    ' section of the Windows Registry for settings
    ' information.
    Debug.Print "Original IniPath setting = " & _
        IIf(DBEngine.IniPath = "", "[Empty]", _
        DBEngine.IniPath)
    DBEngine.IniPath = _
        "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\" & _
        "Jet\4.0\ISAM Formats\Jet 2.x"
    Debug.Print "New IniPath setting = " & _
        IIf(DBEngine.IniPath = "", "[Empty]", _
        DBEngine.IniPath)

End Sub
Public Sub SystemInitialize()
    '建立权限表
    ReDim strName(5), strType(5), strSize(5)
    strName(1) = "编号": strType(1) = dbInteger: strSize(1) = 2
    strName(2) = "人员代号": strType(2) = dbInteger: strSize(2) = 2
    strName(3) = "人员名": strType(3) = dbText: strSize(3) = 20
    strName(4) = "姓名": strType(4) = dbText: strSize(4) = 20
    strName(5) = "密码": strType(5) = dbText: strSize(5) = 20
    Dim strAppName As String, strTableName As String, intMax As Integer, idxName As String
    strAppName = App.Path + "\权限表.mdb"
    strTableName = "权限表"
    intMax = 5
    idxName = "编号"
    DeleteFile strAppName
    CreatDB strAppName, strTableName, intMax, idxName
    '向权限表中添加一个记录
    Dim db As Database, rs As Recordset
    Set db = Workspaces(0).OpenDatabase(strAppName, False, False)
    Set rs = db.OpenRecordset(strTableName)
    rs.AddNew
    rs.Fields("编号") = 1
    rs.Fields("人员代号") = 1
    rs.Fields("人员名") = "系统管理员"
    rs.Fields("姓名") = "李斌杰"
    rs.Fields("密码") = 12345
    rs.Update
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    '建立用户档案
    ReDim strName(23), strType(23), strSize(23)
    strName(1) = "编号": strType(1) = dbLong: strSize(1) = 4
    strName(2) = "户名": strType(2) = dbText: strSize(2) = 50
    strName(3) = "地址": strType(3) = dbText: strSize(3) = 50
    strName(4) = "电话": strType(4) = dbText: strSize(4) = 20
    strName(5) = "户型": strType(5) = dbText: strSize(5) = 20
    strName(6) = "用水性质": strType(6) = dbText: strSize(6) = 20
    strName(7) = "用户开户": strType(7) = dbText: strSize(7) = 50
    strName(8) = "开户行": strType(8) = dbText: strSize(8) = 50
    strName(9) = "帐号": strType(9) = dbLong: strSize(9) = 4
    strName(10) = "纳税号": strType(10) = dbLong: strSize(10) = 4
    strName(11) = "用水人数": strType(11) = dbLong: strSize(11) = 4
    strName(12) = "水表直径": strType(12) = dbLong: strSize(12) = 4
    strName(13) = "水表号": strType(13) = dbLong: strSize(13) = 4
    strName(14) = "始用日期": strType(14) = dbDate: strSize(14) = 8
    strName(15) = "加封日期": strType(15) = dbDate: strSize(15) = 8
    strName(16) = "表井位置": strType(16) = dbText: strSize(16) = 20
    strName(17) = "水表装法": strType(17) = dbText: strSize(17) = 30
    strName(18) = "旁通管径": strType(18) = dbLong: strSize(18) = 4
    strName(19) = "上月读数": strType(19) = dbLong: strSize(19) = 4
    strName(20) = "终止读数": strType(20) = dbLong: strSize(20) = 4
    strName(21) = "备注": strType(21) = dbMemo: strSize(21) = 0
    strName(22) = "注销": strType(22) = dbBoolean: strSize(22) = 1
    strName(23) = "分区": strType(23) = dbInteger: strSize(23) = 2
    strAppName = App.Path + "\用户档案.mdb"
    strTableName = "用户档案"
    intMax = 23
    idxName = "编号"
    DeleteFile strAppName
    CreatDB strAppName, strTableName, intMax, idxName
    '建立水费标准库
    ReDim strName(4), strType(4), strSize(4)
    strName(1) = "编号": strType(1) = dbInteger: strSize(1) = 2
    strName(2) = "用户类型": strType(2) = dbText: strSize(2) = 10
    strName(3) = "收费标准": strType(3) = dbCurrency: strSize(3) = 8
    strName(4) = "污水处理费": strType(4) = dbCurrency: strSize(4) = 8
    strAppName = App.Path + "\水费标准库.mdb"
    strTableName = "水费标准"
    intMax = 4
    idxName = "编号"
    DeleteFile strAppName
    CreatDB strAppName, strTableName, intMax, idxName
End Sub

Public Sub CreatDB(strAppName As String, strTableName As String, intMax As Integer, idxName As String)
    '创建数据库
    Dim db As Database, tb As TableDef, fld As Field, idx As Index
    Set db = Workspaces(0).CreateDatabase(strAppName, dbLangGeneral, dbVersion30)
    Set tb = db.CreateTableDef(strTableName)
    Dim i As Integer
    For i = 1 To intMax
        Set fld = tb.CreateField()
        With fld
            .Name = strName(i)
            .Type = strType(i)
            .Size = strSize(i)
            '这个仅用于 text
            If .Type = dbText Then .AllowZeroLength = -1
        End With
        tb.Fields.Append fld
        tb.Fields.Refresh
    Next
    Set idx = tb.CreateIndex(idxName)
    idx.Primary = True
    Set fld = idx.CreateField(idxName)
    idx.Fields.Append fld
    tb.Indexes.Append idx
    db.TableDefs.Append tb
    db.TableDefs.Refresh
    db.Close
    Set idx = Nothing
    Set fld = Nothing
    Set tb = Nothing
    Set db = Nothing
End Sub

Public Sub DeleteFile(strAppName As String)
    '如果已存在文件,删除它
    If fso.FileExists(strAppName) Then
        Kill strAppName
    End If
End Sub