📄 login.frm
字号:
VERSION 5.00
Begin VB.Form frmLogin
BorderStyle = 3 'Fixed Dialog
Caption = "用户登录"
ClientHeight = 2250
ClientLeft = 45
ClientTop = 330
ClientWidth = 4200
ControlBox = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2250
ScaleWidth = 4200
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton cmdDetal
Caption = "连接数据库"
Height = 375
Left = 2835
TabIndex = 8
Top = 1665
Width = 1275
End
Begin VB.TextBox txtPassword
Height = 300
IMEMode = 3 'DISABLE
Left = 1590
PasswordChar = "*"
TabIndex = 4
Top = 615
Width = 2025
End
Begin VB.ComboBox cboUserName
Height = 300
Left = 1590
Style = 2 'Dropdown List
TabIndex = 3
Top = 135
Width = 2025
End
Begin VB.TextBox txtLoginDate
Appearance = 0 'Flat
BackColor = &H8000000F&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 300
Left = 1590
Locked = -1 'True
TabIndex = 2
Text = "Text1"
Top = 1125
Width = 2085
End
Begin VB.Timer Timer1
Left = 5640
Top = 270
End
Begin VB.CommandButton cmdCancel
Caption = "取消"
Height = 375
Left = 1485
TabIndex = 1
Top = 1665
Width = 1275
End
Begin VB.CommandButton cmdOK
Caption = "确定"
Default = -1 'True
Height = 375
Left = 135
TabIndex = 0
Top = 1665
Width = 1275
End
Begin VB.Image Image1
Height = 480
Left = 135
Picture = "Login.frx":0000
Top = 150
Width = 480
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "密码："
Height = 180
Left = 690
TabIndex = 7
Top = 660
Width = 540
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "用户名："
Height = 180
Left = 690
TabIndex = 6
Top = 195
Width = 720
End
Begin VB.Label Label3
Caption = "登录日期："
Height = 225
Left = 690
TabIndex = 5
Top = 1125
Width = 975
End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public LoginSucceeded As Boolean
Private mbMore As Boolean
Private Function mbGetConnect() As Boolean
Dim CnString As String
Dim mUserName As String
Dim mServerName As String
Dim mPass As String
Dim sFile As String
Dim mDBName As String
On Error GoTo ErrGetConnect
Set CN = New ADODB.Connection
sFile = App.Path & "\lib\login.ini"
If ExistFile(sFile) = False Then
frmLoginDB.Show 1
mbGetConnect = frmLoginDB.mbSucess
Unload frmLoginDB
Exit Function
Else
mServerName = gGetServerInfo(1)
mUserName = gGetServerInfo(2)
mPass = gGetServerInfo(3)
mDBName = gGetServerInfo(4)
End If
If mServerName = "" Or mUserName = "" Or mDBName = "" Then
frmLoginDB.Show 1
mbGetConnect = frmLoginDB.mbSucess
Unload frmLoginDB
Exit Function
End If
' If ExistFile(App.Path & "\data\customer.mdb") = False Then
' MsgBox "找不到数据库文件！请确认" & App.Path & "\data" & "目录下是否存在customer.mdb文件！！", vbInformation, "错误"
' mbGetConnect = False
' Exit Function
' End If
'建立数据库连接
' CnString = "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & App.Path & "\data\customer.mdb"
CnString = "Provider=SQLOLEDB.1;User ID= " & mUserName & ";password=" & mPass & ";Initial Catalog=;Data Source=" & mServerName
CN.Open CnString
If CN Is Nothing Then
MsgBox "数据库连接错误,请重试！！！", vbInformation, "警告"
Exit Function
End If
CN.CursorLocation = adUseClient
'判断该数据库是否存在
If bExistDataBase(mDBName) = False Then
MsgBox "数据库【" & mDBName & "】不存在!!!", vbInformation, ""
CN.Close
Set CN = Nothing
'重新连接
cboUserName.Clear
frmLoginDB.Show 1
mbGetConnect = frmLoginDB.mbSucess
Unload frmLoginDB
Exit Function
End If
'使用数据库
CN.Execute "Use " & mDBName
gUserID = 0
gUserName = "administrator"
mbGetConnect = True
Exit Function
ErrGetConnect:
Screen.MousePointer = vbDefault
mbGetConnect = False
Set CN = Nothing
MsgBox "请检查输入的数据库用户和密码是否正确!!!", vbInformation, "数据库连接错误"
Err.Clear
End Function
Private Sub mListUserName()
'*Purpose:
'* 列表用户名称
Dim sSQL As String
Dim Rs As New ADODB.Recordset
On Error GoTo ErrListUserName
cboUserName.Clear
sSQL = "Select UserName,User_ID from Users"
Screen.MousePointer = vbHourglass
Rs.Open sSQL, CN
Screen.MousePointer = vbDefault
Do While Rs.EOF = False
cboUserName.AddItem Rs.Fields!UserName
cboUserName.ItemData(cboUserName.NewIndex) = Rs.Fields!User_ID
Rs.MoveNext
Loop
Rs.Close
Exit Sub
ErrListUserName:
Screen.MousePointer = vbDefault
gShowMsg "列表用户名出错 frmLogin.mbListUserName"
End Sub
Private Function mbVerify() As Boolean
'*Purpose:
'* 校验输入的信息是否正确
Dim sSQL As String
Dim Rs As New ADODB.Recordset
On Error GoTo ErrVerify
If cboUserName.ListIndex = -1 Then
MsgBox "请选择用户！！！", vbInformation, ""
mbVerify = False
cboUserName.SetFocus
Exit Function
End If
sSQL = "Select User_ID from Users where User_ID = " & cboUserName.ItemData(cboUserName.ListIndex) & " and UserPass = '" & txtPassword & "'"
Screen.MousePointer = vbHourglass
Rs.Open sSQL, CN
Screen.MousePointer = vbDefault
If Rs.EOF Then
Rs.Close
MsgBox "输入的用户密码出错，请重新输入！！！", vbInformation, ""
txtPassword.SetFocus
mbVerify = False
Exit Function
Else
Rs.Close
mbVerify = True
gUserName = cboUserName.Text
gUserID = cboUserName.ItemData(cboUserName.ListIndex)
End If
mbVerify = True
Exit Function
ErrVerify:
Screen.MousePointer = vbDefault
mbVerify = False
gShowMsg "校验输入信息出错 frmLogin.mbVerify"
End Function
Private Sub cmdCancel_Click()
Unload Me
Unload frmSplash
End Sub
Private Sub cmdOK_Click()
If mbVerify() Then
Unload frmSplash
frmMain.Show
'WriteLog CN, gUserName, Format(Now, "yyyy-mm-dd hh:mm:ss"), "用户登录", "用户名：" & gUserName & " 帐套：" & gGetServerInfo(4)
Unload Me
End If
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
KeyAscii = 0
Call cmdCancel_Click
End If
End Sub
Private Sub Form_Load()
Center Me
KeyPreview = True
mbMore = False
Timer1.Enabled = True
Timer1.Interval = 10
txtLoginDate = Format(Now, "yyyy年mm月dd日")
End Sub
Private Sub Timer1_Timer()
Timer1.Enabled = False
If mbGetConnect() Then Call mListUserName
End Sub
Private Sub cmdDetal_Click()
If CN Is Nothing Then
frmLoginDB.Show 1
If frmLoginDB.mbSucess Then Call mListUserName
Unload frmLoginDB
Else
If MsgBox("数据库已经连接成功,是否要重新连接!!!", vbQuestion + vbOKCancel, "") = vbOK Then
Set CN = Nothing
cboUserName.Clear
frmLoginDB.Show 1
If frmLoginDB.mbSucess Then Call mListUserName
Unload frmLoginDB
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -