用户登录.frm

本程序是用Visual Basic来建立数据库管理系统的经典例程。

VERSION 5.00
Begin VB.Form 用户登录 
   BorderStyle     =   0  'None
   Caption         =   "用户登录"
   ClientHeight    =   585
   ClientLeft      =   3075
   ClientTop       =   4830
   ClientWidth     =   5145
   ControlBox      =   0   'False
   DrawStyle       =   1  'Dash
   FillStyle       =   0  'Solid
   Icon            =   "用户登录.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   Moveable        =   0   'False
   Picture         =   "用户登录.frx":0442
   ScaleHeight     =   585
   ScaleWidth      =   5145
   ShowInTaskbar   =   0   'False
   Begin VB.TextBox Text1 
      Alignment       =   1  'Right Justify
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   405
      Left            =   2340
      TabIndex        =   0
      Top             =   120
      Width           =   2625
   End
End
Attribute VB_Name = "用户登录"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'API函数声明
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal X As Long, _
 ByVal hWndInsterAfter As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim hWndl As Long
Const REG_SZ = 1
Const HKEY_CURRENT_USER = &H80000001
Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40
Dim Total As Integer, M As String
Public Falg As Integer
Private Sub Form_Load()
Dim strString As String
On Error GoTo A1
  Falg = 0
  hWndl = FindWindow("Shell_traywnd", "")
  M = GetString(HKEY_CURRENT_USER, "RegData\AA", "")
  Exit Sub
A1:
    strString = " "
    SaveString HKEY_CURRENT_USER, "RegData", "AA", strString
End Sub
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
    Dim strString As String
    Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
    RegQueryValueEx hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize
    strBuf = String(lDataBufSize, Chr$(0))
    RegQueryValueEx hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize
    RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
End Function
Function GetString(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    RegOpenKey hKey, strPath, Ret
    GetString = RegQueryStringValue(Ret, strValue)
    RegCloseKey Ret
End Function
Private Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim Ret
    RegCreateKey hKey, strPath, Ret
    RegSetValue Ret, strValue, REG_SZ, strData, Len(strData)
    RegCloseKey Ret
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim X As Integer
If KeyAscii = 13 Then
  If Text1 <> M Then
   Total = Total + 1
     If Total > 2 Then
        MsgBox "对不起，您无权使用本系统 ！        ", vbExclamation, "提示信息"
        Open App.Path + "\" + "Screen.txt" For Input As #1
        Input #1, apiRECT.Right
        Close #1
        Call SetWindowPos(hWndl, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
        Select Case apiRECT.Right
          Case 1024
            SetDisplayMode 1024, 768, 16
          Case 800
            SetDisplayMode 800, 600, 16
          Case 640
            SetDisplayMode 640, 480, 16
        End Select
        Unload Me
        End
     End If
   MsgBox "您的密码不正确，请重新输入密码 ！", vbExclamation, "提示信息"
   Text1 = ""
 Else
DoEvents
Falg = 1
Unload Me
End If
End If
End Sub