frm_login.frm

一个完整的非接触IC卡会员管理系统

Private Declare Function CreateThreadForRegister Lib "kernel32" Alias "CreateThread" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lParameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetProcAddressRegister Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibraryRegister Lib "kernel32" Alias "FreeLibrary" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)

Public Function fun_RegServer(ByVal FileName As String) As Boolean '注册
    fun_RegServer = RegSvr32(FileName, False)
End Function
      
Public Function fun_UnRegServer(ByVal FileName As String) As Boolean '反注册
    fun_UnRegServer = RegSvr32(FileName, True)
End Function
                      
Private Function RegSvr32(ByVal FileName As String, bUnReg As Boolean) As Boolean
Dim lLib         As Long
Dim lProcAddress         As Long
Dim lThreadID         As Long
Dim lSuccess         As Long
Dim lExitCode         As Long
Dim lThread         As Long
Dim bAns         As Boolean
Dim sPurpose         As String
sPurpose = IIf(bUnReg, "DllUnregisterServer", "DllRegisterServer")
If Dir(FileName) = "" Then Exit Function
lLib = LoadLibraryRegister(FileName)
'载入文件
If lLib = 0 Then Exit Function
lProcAddress = GetProcAddressRegister(lLib, sPurpose)
If lProcAddress = 0 Then
    '不是ActiveX控件
    FreeLibraryRegister lLib
    Exit Function
Else
    lThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread)
    If lThread Then
        lSuccess = (WaitForSingleObject(lThread, 10000) = 0)
        If Not lSuccess Then
                    Call GetExitCodeThread(lThread, lExitCode)
                    Call ExitThread(lExitCode)
                    bAns = False
                    FreeLibraryRegister lLib
                    Exit Function
        Else
                    bAns = True
        End If
        CloseHandle lThread
        FreeLibraryRegister lLib
    Else
        FreeLibraryRegister lLib
    End If
End If
RegSvr32 = bAns
End Function

Private Sub Command1_Click()
'    If fun_UnRegServer(App.Path & "\crystl32.ocx") = True Then
'
'    End If
'
'    If fun_RegServer(App.Path & "\crystl32.ocx") = True Then
'
'    End If
    
    sN = Right(Format(GetSerialNumber("c:\"), "00000000000000"), 12)
    snn = sN & "3721"
    sN = "1976-" & Mid(sN, 1, 4) & "-" & Mid(sN, 5, 4) & "-" & Mid(sN, 9, 4) & "-3721"
    
    
    n = 1
    For i = 0 To 7
        skeyID(i) = "&H" + Mid(snn, n, 2)
        n = n + 2
    Next i
    skeyPI(0) = &HAA
    skeyPI(1) = &H19
    skeyPI(2) = &HBB
    skeyPI(3) = &H76
    skeyPI(4) = &HCC
    skeyPI(5) = &H4
    skeyPI(6) = &HDD
    skeyPI(7) = &H19
    st = ic_encrypt(skeyPI(0), skeyID(0), 8, skeyLA(0)) 'KEY
    strKeyS = ""
    For i = 0 To 7
        strKeyS = strKeyS & Right("00" + hex(skeyLA(i)), 2)
    Next i
    
    Set rs = GetRecordset(maSys_db, "select *  from LinkLoginList where keyname='" & sN & "'")
    If rs.EOF And rs.BOF Then
        MsgBox "系统未注册，请检查！", vbCritical + vbOKOnly, "提示"
        Me.Hide
        sJc = ""
        frmKey.Show 1
        If sJc = "注册成功" Then
             Me.Show
             Exit Sub
        Else
             Unload Me
             Exit Sub
        End If
    Else
        If strKeyS <> Trim(rs.Fields("keypassword")) Then
            MsgBox "系统未注册，请检查！", vbCritical + vbOKOnly, "提示"
            Me.Hide
            sJc = ""
            frmKey.Show 1
            If sJc = "注册成功" Then
                 Me.Show
                 Exit Sub
            Else
                 Unload Me
                 Exit Sub
            End If
        End If
    End If
    
    If i = 2 Then
         MsgBox "您无权访问本系统！", vbCritical + vbOKOnly, "警告"
         
         Unload LinkMain
         Unload Me
    End If
    
    If login_name.Text <> "" Then
        psUserdb.Open "select * from 用户信息表", maSys_db, 3, 3
        If psUserdb.RecordCount = 0 Then
            psUserdb.Close
            If login_name <> "sys" Then MsgBox "请用sys登录！", vbCritical + vbOKOnly, "警告": Exit Sub
            If Check1.Value = 1 Then
                  DoEvents
                  SaveRegKey HKEY_CURRENT_USER, "lock", "User", login_name.Text
                  SaveRegKey HKEY_CURRENT_USER, "lock", "SavePassword", "T"
                  SaveRegKey HKEY_CURRENT_USER, "lock", "Password", login_password.Text
            Else
                  DoEvents
                  SaveRegKey HKEY_CURRENT_USER, "lock", "User", ""
                  SaveRegKey HKEY_CURRENT_USER, "lock", "SavePassword", "F"
                  SaveRegKey HKEY_CURRENT_USER, "lock", "Password", ""
            End If
            strUserName = "sys"
            sLogin = "管理员"
            Unload Me
            'LinkMain.Show
            frm_menu.Show
        Else
            psUserdb.Close
            psUserdb.Open "select * from 用户信息表 where 登录名称='" & login_name.Text & "'", maSys_db, 3, 3
            If psUserdb.RecordCount <> 0 Then
                 'DeCrypt(txtNewUserPassword.Text, "19760419")
                 If psUserdb.Fields("登录密码") = DeCrypt(login_password.Text, "19760419") Then
                      strUserName = psUserdb.Fields("员工姓名")
                      sLogin = psUserdb.Fields("用户类型")
                      psUserdb.Close
                      
                      If Check1.Value = 1 Then
                            DoEvents
                            SaveRegKey HKEY_CURRENT_USER, "lock", "User", login_name.Text
                            SaveRegKey HKEY_CURRENT_USER, "lock", "SavePassword", "T"
                            SaveRegKey HKEY_CURRENT_USER, "lock", "Password", login_password.Text
                      Else
                            DoEvents
                            SaveRegKey HKEY_CURRENT_USER, "lock", "User", ""
                            SaveRegKey HKEY_CURRENT_USER, "lock", "SavePassword", "F"
                            SaveRegKey HKEY_CURRENT_USER, "lock", "Password", ""
                      End If
                      
                      Unload Me
                      'LinkMain.Show
                      frm_menu.Show
                      Exit Sub
                 Else
                      Label2.Caption = "密码错误，请重试！"
                      i = i + 1
                 End If
            Else
                
                 Label2.Caption = "该用户不存在！"
                 i = i + 1
            End If
            psUserdb.Close
        End If
    Else
        Label2.Caption = "输入不能为空！"
        
    End If
    
End Sub


Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Dim sUser As String
    Dim sGetPassword As String
'    SaveRegKey HKEY_CURRENT_USER, "lock", "User", login_name.Text
'    SaveRegKey HKEY_CURRENT_USER, "lock", "SavePassword", login_password.Text
    
    Me.Top = (Screen.Height - Me.Height) / 2
    Me.Left = (Screen.Width - Me.Width) / 2
    
    Check1.Value = 0
    If GetRegKey(HKEY_CURRENT_USER, "lock", "SavePassword", "") = "T" Then
        Check1.Value = 1
        sUser = GetRegKey(HKEY_CURRENT_USER, "lock", "User", "")
        login_name.Text = sUser
        sGetPassword = GetRegKey(HKEY_CURRENT_USER, "lock", "Password", "")
        login_password.Text = sGetPassword
    End If
End Sub

Private Sub login_name_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 And login_name.Text <> "" Then
       login_password.SetFocus
    End If
End Sub

Private Sub login_password_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
       Command1.SetFocus
    End If
End Sub

Private Sub login_password_KeyPress(KeyAscii As Integer)
    If KeyAscii > 57 Or KeyAscii < 48 And KeyAscii <> 8 And KeyAscii <> 45 Then
        KeyAscii = 0
    End If
End Sub
Function GetSerialNumber(strDrive As String) As Long
    Dim SerialNum As Long
    Dim Res As Long
    Dim Temp1 As String
    Dim Temp2 As String
    Temp1 = String$(255, Chr$(0))
    Temp2 = String$(255, Chr$(0))
    Res = GetVolumeInformation(strDrive, Temp1, _
    Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
    GetSerialNumber = SerialNum
End Function