mdlmain.bas

利用VB+ACCESS开发的专用布料管理系统

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 Flash As Boolean             '判定Flash窗口是否从菜单激活
Public ReturnSql As String

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

'记录FrmStatus用来打开那个数据库的传递参数
'=================================================================================================================================
Public FrmStatusType As String              'FrmStatus窗体打开类型数据变量
'=================================================================================================================================

'用来关闭打开的数据窗口的数据类型
'=================================================================================================================================
Private Type FormStatus
    FrmWarrant As Boolean         '权限管理
End Type
Public FrmStu As FormStatus
'=================================================================================================================================

Private Type ExlCell
    Row As Long
    Col As Long
End Type

Public OpenType  As String

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=;"
    DbLoginSql = "provider=microsoft.jet.oledb.4.0;data source=" & _
        App.Path & "\sysdb2.mdb;jet oledb:database password=;"
    
    Dim i As Integer
    i = 0
TryAgain:
    FrmTestSql.Show vbModal
    If ServerIsOpen = False Then
        MsgBox "请检查数据库是否正确运行！！" & Chr$(13) & Chr$(10) & Chr$(13) _
            & "按“确定”退出程序...", vbOKOnly + vbInformation, "打不开数据库"
        End
    End If
    
    ReDim W_Stack(0)
    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))
    Next i
    Pwd_Len = PwdLenToInt(Left(TempPwd, 1))
    Pwd = Mid(TempPwd, 2, Pwd_Len)
    ReductionPwd = Pwd
End Function

Public Function PwdLenToInt(PwdLen As String) As Integer
    Select Case PwdLen
        Case "0"
            PwdLenToInt = 0
        Case "1"
            PwdLenToInt = 1
        Case "2"
            PwdLenToInt = 2
        Case "3"
            PwdLenToInt = 3
        Case "4"
            PwdLenToInt = 4
        Case "5"
            PwdLenToInt = 5
        Case "6"
            PwdLenToInt = 6
        Case "7"
            PwdLenToInt = 7
        Case "8"
            PwdLenToInt = 8
        Case "9"
            PwdLenToInt = 9
        Case "A"
            PwdLenToInt = 10
        Case "B"
            PwdLenToInt = 11
        Case "C"
            PwdLenToInt = 12
        Case "D"
            PwdLenToInt = 13
        Case "E"
            PwdLenToInt = 14
        Case "F"
            PwdLenToInt = 15
        Case "G"
            PwdLenToInt = 16
        Case "H"
            PwdLenToInt = 17
        Case "I"
            PwdLenToInt = 18
        Case "J"
            PwdLenToInt = 19
        Case "K"
            PwdLenToInt = 20
    End Select
End Function

Public Function PwdLenToString(PwdLen As Integer) As String
    Select Case PwdLen
        Case 0
            PwdLenToString = "0"
        Case 1