frmlogin.frm

一个经详细测试、用VB6编写的工业企业进销存软件

VERSION 5.00
Begin VB.Form frmLogin 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "登录"
   ClientHeight    =   2910
   ClientLeft      =   30
   ClientTop       =   330
   ClientWidth     =   3900
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2910
   ScaleWidth      =   3900
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Tag             =   "Login"
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   360
      Left            =   2100
      TabIndex        =   4
      Tag             =   "Cancel"
      Top             =   2304
      Width           =   1140
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   360
      Left            =   492
      TabIndex        =   3
      Tag             =   "OK"
      Top             =   2304
      Width           =   1140
   End
   Begin VB.TextBox txtPassword 
      Height          =   288
      IMEMode         =   3  'DISABLE
      Left            =   1548
      PasswordChar    =   "*"
      TabIndex        =   2
      Top             =   1812
      Width           =   2064
   End
   Begin VB.TextBox txtUserName 
      Height          =   288
      Left            =   1548
      TabIndex        =   1
      Top             =   1416
      Width           =   2064
   End
   Begin VB.Label Label1 
      Caption         =   "工厂进销存   管理系统"
      BeginProperty Font 
         Name            =   "华文彩云"
         Size            =   24
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000001&
      Height          =   972
      Left            =   480
      TabIndex        =   6
      Top             =   120
      Width           =   2532
   End
   Begin VB.Label lblLabels 
      Caption         =   "密  码:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Index           =   1
      Left            =   348
      TabIndex        =   0
      Tag             =   "&Password:"
      Top             =   1824
      Width           =   1080
   End
   Begin VB.Label lblLabels 
      Caption         =   "用户名:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Index           =   0
      Left            =   348
      TabIndex        =   5
      Tag             =   "&User Name:"
      Top             =   1440
      Width           =   1080
   End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpbuffer As String, nSize As Long) As Long


Public OK As Boolean
Private Sub Form_Load()
    Dim sBuffer As String
    Dim lSize As Long


    sBuffer = Space$(255)
    lSize = Len(sBuffer)
    Call GetUserName(sBuffer, lSize)
    If lSize > 0 Then
        txtUserName.Text = Left$(sBuffer, lSize)
    Else
        txtUserName.Text = vbNullString
    End If
End Sub



Private Sub cmdCancel_Click()
    OK = False
    Me.Hide
End Sub


Private Sub cmdOK_Click()
    'To Do - 创建测试密码是否正确
    '检查正确密码
    Dim mrc As ADODB.Recordset
    Dim txtSQL As String
    Dim MsgText As String
    
  On Error GoTo myErr
        If Trim(txtUserName & " ") <> "" Then
            txtSQL = "select * from users where id='" & Trim(txtUserName & " ") & "'"
            Set mrc = ExecuteSQL(txtSQL, MsgText)
            
            If mrc.EOF = True Then
                MsgBox "没有这个用户，再重新输入！", vbOKOnly + vbExclamation, "登录"
                        txtUserName.SetFocus
                       
            Else    '登陆成功
                If Trim(txtPassword & " ") = Trim(mrc!Password) Then
                    sUserName = Trim(txtUserName)
                    If Permission(sUserName, 10, 19) = True Then
                        OK = True
                        Me.Hide
                    Else
                        End
                    End If
                Else
                    MsgBox "密码错误，再试一次！", vbOKOnly + vbExclamation, "登录"
                        txtPassword.SetFocus
                        txtPassword.SelStart = 0
                        txtPassword.SelLength = Len(txtPassword.Text)
                End If
            End If
        Else
            MsgBox "没有这个用户，再重新输入！", vbOKOnly + vbExclamation, "登录"
            txtUserName.SetFocus
        End If
        miCount = miCount + 1
        If miCount = 3 Then
            Me.Hide
        End If
        Exit Sub
        
myErr:
    ShowError
End Sub
'检查用户是否可以进入程序
Public Function Permission(Id As String, Begin As Integer, Over As Integer) As Boolean
    Dim recTemp As ADODB.Recordset
    Dim sSQL As String
    Dim MsgText As String
  On Error GoTo myErr
    '检查用户的权限
        sSQL = "select distinct module from permission where id='" & sUserName & "'"
        sSQL = sSQL & " and module between " & Begin & " and " & Over
        Set recTemp = ExecuteSQL(sSQL, MsgText)
        '判断是否有进入的权限
        If recTemp.EOF Then
            MsgBox "您没有进入系统的权限!", vbOKOnly + vbExclamation, "登录失败"
            Permission = False
        Else
            Permission = True
        End If
    Exit Function
    
myErr:
    ShowError
End Function