frmlogin.frm

通用样品管理系统是一个商业程序,功能界面都还不错!

VERSION 5.00
Begin VB.Form frmLogin 
   AutoRedraw      =   -1  'True
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "登录..."
   ClientHeight    =   1845
   ClientLeft      =   2835
   ClientTop       =   3480
   ClientWidth     =   4080
   ControlBox      =   0   'False
   Icon            =   "frmLogin.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1090.087
   ScaleMode       =   0  'User
   ScaleWidth      =   3830.899
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.ComboBox UserTxt 
      Height          =   300
      Left            =   1350
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   345
      Width           =   2325
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Left            =   330
      Picture         =   "frmLogin.frx":000C
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   6
      Top             =   1155
      Width           =   480
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(O)"
      Default         =   -1  'True
      Height          =   390
      Left            =   1365
      TabIndex        =   3
      Top             =   1245
      Width           =   1140
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   390
      Left            =   2550
      TabIndex        =   4
      Top             =   1245
      Width           =   1140
   End
   Begin VB.TextBox txtPassword 
      Height          =   285
      IMEMode         =   3  'DISABLE
      Left            =   1335
      PasswordChar    =   "*"
      TabIndex        =   0
      Top             =   750
      Width           =   2325
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H000000FF&
      Caption         =   "演示版"
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   3540
      TabIndex        =   7
      Top             =   0
      Width           =   540
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      Caption         =   "用户名(&U):"
      Height          =   180
      Index           =   0
      Left            =   285
      TabIndex        =   2
      Top             =   405
      Width           =   900
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      Caption         =   "密码(&P):"
      Height          =   180
      Index           =   1
      Left            =   450
      TabIndex        =   5
      Top             =   795
      Width           =   720
   End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim LOGINNO As Integer
Dim PassYu(10) As String
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    '检查密码的正确性
Dim x As Long
    x = UserTxt.ListIndex
    '如果有加密，解密方法放此处，将PassYu(X)数组中的值，
    '转换成原来信息
  Dim FindStr As String
'将加密口令变回来
     Dim shiftStr As String, shiftStrR As Variant, shiftNum As Integer, ili As Integer, sureStr As String
      shiftStr = Trim(txtPassword.Text)
      shiftNum = Len(shiftStr)
      ili = 1
      sureStr = ""
        For ili = 1 To shiftNum
            shiftStrR = Mid(shiftStr, ili, 1)
            shiftStrR = Asc(shiftStrR)
            shiftStrR = shiftStrR - 3
            shiftStrR = Chr(shiftStrR)
            sureStr = sureStr & shiftStrR
        Next
        '密匙
   '开始查找 sureStr为解除的口令
    If sureStr = PassYu(x) Then
        UserText = UserTxt.Text
        '密码正确时
        frmLogin.MousePointer = 11
        Load MDIForm1
        Unload Me
        frmSplash.Show
        Exit Sub
    Else
        MsgBox "无效的密码，再试一次！", 32, "登录"
        LOGINNO = LOGINNO + 1
    If LOGINNO > 3 Then
        MsgBox "对不起，您不能使用该系统！", 64, "登录失败"
        Unload Me
        Exit Sub
     End If
        txtPassword.SetFocus
        SendKeys "{Home}+{End}"
    End If
End Sub
Private Sub Form_Load()
  frmLogin.HelpContextID = 9
Dim retValue As Long
    retValue = SetActiveWindow(Me.hwnd)
  Browser = CurDir()
  '设计时定义temp dir
  'Browser = "c:\vb5\sample"
    If Right(Browser, 1) <> "\" Then
       Browser = Browser + "\"
    End If
If App.PrevInstance = True Then
   MsgBox "样品管理系统已经启动，请按 Alt+Tab 切换！", vbOKOnly + 48, "警告..."
   Unload Me
   Exit Sub
End If

'配置网络数据库
    Dim Fn As Integer
        Fn = FreeFile
Dim DataFile As String, NetFile As String
    DataFile = Browser + "sys\net.ini"
    On Error GoTo NetInI
    Open DataFile For Input As Fn
    Do While Not EOF(Fn)
    Line Input #Fn, NetFile
    If EOF(Fn) Then Exit Do
       NetFile = Trim(NetFile)
    Loop
    Close Fn
 If Trim(NetFile) = "" Then
       '写入自己的路径
       Dim TempPath As String
           TempPath = Browser + "sys"
       Open DataFile For Output As Fn
       Print #Fn, TempPath
       Close Fn
       '再次打开
       Open DataFile For Input As Fn
       Do While Not EOF(Fn)
          Line Input #Fn, NetFile
        If EOF(Fn) Then Exit Do
           NetFile = Trim(NetFile)
       Loop
          Close Fn
 End If
       Dim NetFile1 As String, NetFile0 As String
       Dim NetFile2 As String
       '检查路径是否正确
       If Right(NetFile, 1) <> "\" Then
            NetFile = NetFile + "\"
         End If
       NetFile0 = NetFile & "Sample.MDB"
       NetFile1 = NetFile & "USER.MDB"
       NetFile2 = NetFile & "DATA.MDB"
       '继续增加数据库...1
       '检测数据库的正确性
       On Error GoTo NetErr
       Open NetFile0 For Input As Fn
       Close Fn
       Open NetFile1 For Input As Fn
       Close Fn
       Open NetFile2 For Input As Fn
       Close Fn
       '继续增加数据库...2
       
       
       '网络数据库
       
       SampleData = NetFile0
       UserData = NetFile1
       ConfigData = NetFile2
       
       '继续增加数据库...3
           
'结束配置

Dim DB As Database, EF As Recordset, x As Long, I As Long
Dim UserYu(10) As String
    Set DB = OpenDatabase(UserData)
    Set EF = DB.OpenRecordset("MAIN", dbOpenTable)
        x = EF.RecordCount
    Set EF = DB.OpenRecordset("Select 操作员,口令 From MAIN", dbOpenDynaset)
    For I = 0 To x - 1
        UserYu(I) = EF.Fields(0).Value
        If Not IsNull(EF.Fields(1).Value) Then
           PassYu(I) = EF.Fields(1).Value
        End If
        UserTxt.AddItem UserYu(I), I
        EF.MoveNext
    Next
     DB.Close
If x >= 1 Then
    UserTxt.ListIndex = 0
End If
    LOGINNO = 1
    
 
    '退出
    Exit Sub
NetInI:
    MsgBox "Net.ini  配置文件没有找到,请与供应商联系!     ", vbInformation
    UserTxt.Enabled = False
    txtPassword.Enabled = False
    cmdOK.Enabled = False
    lblLabels(0).Enabled = False
    lblLabels(1).Enabled = False
    Exit Sub
NetErr:
    MsgBox " Net.ini  配置文件造破坏,修改方法如下：   " & vbCrLf & vbCrLf & " 打开 Sample\Sys\Net.ini 文件,删除文件内的内容并保存,然后重新登录!  ", vbInformation
    UserTxt.Enabled = False
    txtPassword.Enabled = False
    cmdOK.Enabled = False
    lblLabels(0).Enabled = False
    lblLabels(1).Enabled = False
    Exit Sub
End Sub

Private Sub UserTxt_Click()
 SendKeys "{Tab}"
End Sub

Private Sub UserTxt_LostFocus()
 txtPassword.SetFocus
End Sub