mdlmain.bas

此为水费收费管理系统

Attribute VB_Name = "MdlMain"
Option Explicit
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const FLAG = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
    ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    
'用来打开只选择目录而不选择文件的对话框API函数、数据类型和常量
'==============================================================================================================================
    Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
    Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
        ByVal lpString2 As String) As Long
    Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
    Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal _
        lpBuffer As String) As Long
    
    Public Type BrowseInfo
        hWndOwner As Long
        pIDLRoot As Long
        pszDisplayName As Long
        lpszTitle As Long
        ulFlags As Long
        lpfnCallback As Long
        lParam As Long
        iImage As Long
    End Type
    Public Const BIF_RETURNONLYFSDIRS = 1
    Public Const MAX_PATH = 260
'==============================================================================================================================

Private Type LgTimeStruct
    LgNow As Date               '记录登录时间：包含日期和时间
    LgTime As Date              '记录登陆时间：只有日期，没有时间
    LgDate As String            '记录登陆日期
    LgMonth As String           '记录登陆月份
    LgYear As String            '记录登陆年份
End Type

Private Type LgWarrantStruct
    QxName As String            '登陆用户对应权限名称；
    Warrant As String           '记录登陆用户对应权限是否可用！
End Type

'定义系统变量，在程序开始运行时返回！
'===========================================================================================================================
Public LoginBh As String                '登陆者编号；
Public LoginUser As String              '登录者名称；
Public Password As String               '登录者密码；
Public LoginTime As LgTimeStruct        '登陆时间。
Public LoginQx() As LgWarrantStruct     '登录者权限；
'===========================================================================================================================

Public Flash As Boolean             '判定Flash窗口是否从菜单激活
Public ReturnSql As String

Public ServerIsOpen As Boolean      '判定系统数据库是否正确连接。
Public DbConnectSql As String       '系统数据库连接字符串。
Public SysDbPath As String          '系统打印数据库路径；
Public DbLoginSql As String         '系统登陆用户、数据备份用数据库；

'用来关闭打开的数据窗口的数据类型
'=================================================================================================================================
Private Type PntTypeStruct
    XlsOrNot As Boolean     '打印到EXCEL还是普通打印：true EXCEL   false 普通打印
    PntOrNot As Boolean     '是否打印：true 打印   false 不打印
    TypeOfPnt As Integer      '打印方式设置：共有五种方式
    
    OneOrMore As Boolean    '打印方式：true 单用户打印      false 多用户打印
    BankOrNot As Boolean    '打印方式：true 打印银行报表    false 不打印银行报表
End Type
Public PntType As PntTypeStruct
'=================================================================================================================================

Public FrmStatusType As String

Public OpenType  As String
Public Cn_Rsh As New ADODB.Connection

Private Sub Main()
    If App.PrevInstance = True Then
        MsgBox "系统正在运行,不能同时运行多个实例...", vbCritical + vbOKOnly, "加载错误!!"
        End
    End If

    SysDbPath = App.Path & "\chxn"
    DbConnectSql = "provider=microsoft.jet.oledb.4.0;data source=" & _
        SysDbPath & "\maindb.mdb;jet oledb:database password=indestyp;"
    DbLoginSql = "provider=microsoft.jet.oledb.4.0;data source=" & _
        App.Path & "\sysdb2.mdb;jet oledb:database password=indestyp;"
    
    FrmTestSql.Show vbModal
    If ServerIsOpen = False Then
        MsgBox "请检查数据库是否正确运行！！" & Chr$(13) & Chr$(10) & Chr$(13) _
            & "按“确定”退出程序...", vbOKOnly + vbInformation, "打不开数据库"
        End
    End If
    
    Cn_Rsh.Open DbConnectSql
            
''    Dim Rec As New ADODB.Recordset
''    Dim Rs As New ADODB.Recordset
''    Cn_Rsh.BeginTrans
'''    Rs.CursorLocation = adUseClient
'''    Rs.Open "select * from lqryk", Cn_Rsh, adOpenDynamic, adLockOptimistic
''
''    Set Rec = Cn_Rsh.Execute("select *,lqryk.id from sheet1 left join lqryk on lqryk.hsh=val(sheet1.编号) order by sheet1.编号")
''    Do While Not Rec.EOF
''        Cn_Rsh.Execute "update lqwater set ncount=" & IIf(IsNull(Rec.Fields("上期度数").Value), 0, _
''                Rec.Fields("上期度数").Value) & _
''            " , havemoney='" & IIf(IsNull(Rec.Fields("收费情况").Value), " ", _
''                Rec.Fields("收费情况").Value) & "' where id=" & IIf(IsNull(Rec.Fields("id").Value), 99999, Val(Rec.Fields("id").Value))
'''        Rs.AddNew
'''        Rs.Fields("hsh").Value = Rec.Fields("编号").Value
'''        Rs.Fields("yname").Value = " " ' IIf(IsNull(Rec.Fields("业户名").Value), " ", Rec.Fields("业户名").Value)
'''        Rs.Fields("name").Value = IIf(IsNull(Rec.Fields("户名").Value), " ", Rec.Fields("户名").Value)
'''
'''        Rs.Fields("length").Value = 0 ' Rec.Fields("编号").Value
'''        Rs.Fields("pid").Value = IIf(IsNull(Rec.Fields("帐号").Value), " ", Rec.Fields("帐号").Value)
'''        Rs.Fields("phone").Value = IIf(IsNull(Rec.Fields("联系电话").Value), " ", Rec.Fields("联系电话").Value)
'''        Rs.Fields("water").Value = " " ' Rec.Fields("楼号").Value
'''        Rs.Fields("sanitation").Value = " " ' Rec.Fields("编号").Value
'''        Rs.Update
''        Rec.MoveNext
''    Loop
''
''    Set Rec = Cn_Rsh.Execute("select *,lqryk.id from sheet2 left join lqryk on lqryk.hsh=val(sheet2.编号) order by sheet2.编号")
''    Do While Not Rec.EOF
''        Cn_Rsh.Execute "update lqwater set ncount=" & IIf(IsNull(Rec.Fields("上期度数").Value), 0, Rec.Fields("上期度数").Value) & _
''            " , havemoney='" & IIf(IsNull(Rec.Fields("收费情况").Value), " ", Rec.Fields("收费情况").Value) & "' where id=" & IIf(IsNull(Rec.Fields("id").Value), 99999, Val(Rec.Fields("id").Value))
'''        Rs.AddNew
'''        Rs.Fields("hsh").Value = Rec.Fields("编号").Value
'''        Rs.Fields("yname").Value = IIf(IsNull(Rec.Fields("业户名").Value), " ", Rec.Fields("业户名").Value)
'''        Rs.Fields("name").Value = IIf(IsNull(Rec.Fields("户名").Value), " ", Rec.Fields("户名").Value)
'''
'''        Rs.Fields("length").Value = 0 ' Rec.Fields("编号").Value
'''        Rs.Fields("pid").Value = IIf(IsNull(Rec.Fields("帐号").Value), " ", Rec.Fields("帐号").Value)
'''        Rs.Fields("phone").Value = IIf(IsNull(Rec.Fields("联系电话").Value), " ", Rec.Fields("联系电话").Value)
'''        Rs.Fields("water").Value = " " ' Rec.Fields("楼号").Value
'''        Rs.Fields("sanitation").Value = " " ' Rec.Fields("编号").Value
'''        Rs.Update
''        Rec.MoveNext
''    Loop
''    Cn_Rsh.CommitTrans

    Flash = False
    FrmLogin.Show

End Sub

Public Function ConVertPwd(Pwd As String) As String
    Dim Pwd_Len As Integer
    Dim i As Integer
    Pwd_Len = Len(Pwd)
    If Pwd_Len <= 0 Then
        ConVertPwd = ""
        Exit Function
    End If
    If Pwd_Len > 20 Or Pwd_Len <= 0 Then
        ConVertPwd = "Length Error!"
        Exit Function
    End If
    If Pwd_Len < 20 Then
        For i = 1 To 20 - Pwd_Len
            Pwd = Pwd & Chr(Asc(Mid(Pwd, i, 1)) - i)
        Next i
    End If
    Pwd = PwdLenToString(Pwd_Len) & Pwd
    Dim TempPwd As String
    TempPwd = TempPwd & Chr(Asc(Mid(Pwd, 1, 1)) - Asc((1 Mod 10)))
    For i = 2 To 21
        TempPwd = TempPwd & Chr(Asc(Mid(Pwd, i, 1)) - (i Mod 10))
    Next i
    ConVertPwd = TempPwd
End Function

Public Function ReductionPwd(Pwd As String) As String
    Dim Pwd_Len As Integer
    Dim TempPwd As String
    Dim i As Integer
    If Pwd = "" Then Exit Function
    TempPwd = TempPwd & Chr(Asc(Mid(Pwd, 1, 1)) + Asc((1 Mod 10)))
    For i = 2 To Len(Pwd)
        TempPwd = TempPwd & Chr(Asc(Mid(Pwd, i, 1)) + (i Mod 10))