📄 frmlogin.frm
字号:
VERSION 5.00
Begin VB.Form frmLogin
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
ClientHeight = 6285
ClientLeft = 45
ClientTop = 330
ClientWidth = 6630
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmLogin.frx":0000
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6285
ScaleWidth = 6630
StartUpPosition = 2 '屏幕中心
Begin Manage.Xp_ProgressBar proBar
Height = 255
Left = 1440
TabIndex = 11
Top = 2280
Visible = 0 'False
Width = 4575
_ExtentX = 8070
_ExtentY = 450
End
Begin Manage.xpcmdButton cmdCancel
Cancel = -1 'True
Height = 345
Left = 5460
TabIndex = 8
Top = 5880
Width = 1095
_ExtentX = 1931
_ExtentY = 609
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "关闭(&C)"
ForeColor = -2147483630
End
Begin Manage.xpcmdButton CmdExit
Height = 345
Left = 3360
TabIndex = 7
Top = 2880
Width = 1095
_ExtentX = 1931
_ExtentY = 609
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "退出(&Q)"
ForeColor = -2147483630
End
Begin Manage.xpcmdButton cmdOK
Default = -1 'True
Height = 345
Left = 2160
TabIndex = 6
Top = 2880
Width = 1095
_ExtentX = 1931
_ExtentY = 609
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "登录(&L)"
ForeColor = -2147483630
End
Begin VB.TextBox txtConceal
BackColor = &H00C0E0FF&
ForeColor = &H00400040&
Height = 300
IMEMode = 3 'DISABLE
Left = 2160
MaxLength = 40
PasswordChar = "*"
TabIndex = 5
Top = 2340
Visible = 0 'False
Width = 2295
End
Begin VB.Timer tmrLoad
Interval = 100
Left = 6240
Top = 0
End
Begin VB.ComboBox cboName
BackColor = &H00C0E0FF&
ForeColor = &H00400040&
Height = 300
ItemData = "frmLogin.frx":000C
Left = 2160
List = "frmLogin.frx":000E
Style = 2 'Dropdown List
TabIndex = 3
Top = 1980
Visible = 0 'False
Width = 2295
End
Begin VB.TextBox txtPassword
BackColor = &H00C0E0FF&
ForeColor = &H00400040&
Height = 300
IMEMode = 3 'DISABLE
Left = 2160
MaxLength = 20
PasswordChar = "*"
TabIndex = 0
TabStop = 0 'False
Top = 2340
Visible = 0 'False
Width = 2175
End
Begin VB.TextBox txtInfo
ForeColor = &H00FF0000&
Height = 4095
Left = 60
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 9
Top = 1680
Width = 6540
End
Begin VB.Image imgLogo
Height = 735
Left = 5280
Top = 1680
Width = 855
End
Begin VB.Image Image1
Height = 840
Left = 300
Picture = "frmLogin.frx":0010
Top = 1860
Width = 840
End
Begin VB.Label lblClew
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "初次登录系统,默认用户名为admin,密码为空"
ForeColor = &H00FF0000&
Height = 180
Left = 1680
TabIndex = 10
Top = 3360
Width = 3510
End
Begin VB.Image imgMain
Height = 1695
Left = 0
Picture = "frmLogin.frx":0B78
Top = 0
Width = 6660
End
Begin VB.Label lblTitle
AutoSize = -1 'True
BackStyle = 0 'Transparent
ForeColor = &H00C00000&
Height = 180
Left = 1440
TabIndex = 4
Top = 1800
Width = 90
End
Begin VB.Label lblName
AutoSize = -1 'True
BackColor = &H00C0FFFF&
BackStyle = 0 'Transparent
Caption = "用户名:"
ForeColor = &H00800000&
Height = 180
Left = 1440
TabIndex = 2
Top = 1980
Visible = 0 'False
Width = 630
End
Begin VB.Label lblPassword
AutoSize = -1 'True
BackColor = &H00C0FFFF&
BackStyle = 0 'Transparent
Caption = "密 码:"
ForeColor = &H00800000&
Height = 180
Left = 1440
TabIndex = 1
Top = 2340
Visible = 0 'False
Width = 630
End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '用来延时
'Dim HyperJump '点击label时产生点击网页链接的效果，并打开指定的web地址
Dim intCount As Integer
Dim downAddress As String
Dim strPopedom As String
Private Sub cmdCancel_Click()
MDIMain.Enabled = True
Unload Me
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
On Error GoTo loadErr
If Len(txtPassword.Text) = 0 And cboName.Text <> "admin" Then
MsgBox "输入密码不能为空!", vbExclamation
txtPassword.SetFocus
Exit Sub
Else
With adoLink
If .State = adStateOpen Then .Close
.Open "select * from 系统管理员 where 用户名='" & cboName.Text & "'", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
If .EOF = False Then
If Trim(txtPassword.Text) = Trim(.Fields("密码")) Then
gstrName = Trim(cboName.Text)
gblnPopedom = .Fields("权限")
Unload Me
MDIMain.Show
Else
MsgBox "密码错误,请重新输入!", vbOKOnly + vbCritical, App.Title
txtPassword.Text = ""
txtConceal.Text = ""
txtConceal.SetFocus
End If
Else
Unload Me
MDIMain.Show
End If
End With
End If
Exit Sub
loadErr:
Call ErrMsg(Err.Number, Err.Description)
End Sub
Private Sub Form_Load()
On Error Resume Next
SaveSetting App.Title, "Settings", "Version", App.Major & "." & App.Minor
cmdOK.Visible = False
cmdExit.Visible = False
imgLogo.Visible = False
imgLogo.Picture = LoadPicture(App.Path & "\pic\logo.gif")
If blnAbout = False Then
Me.Icon = frmTool.Icon
DisSysMenu Me.hwnd, 6
Me.Height = 3120
proBar.Visible = True
proBar.Max = 100
txtInfo.Visible = False
cmdCancel.Visible = False
txtConceal.Enabled = False
frmTool.Hide
lblTitle.Caption = "欢迎使用" & App.Title & "!" & vbCrLf & "正在连接数据库..."
gstrProvider = frmTool.cboProvider.Text
gstrDatabaseName = frmTool.txtDatabase.Text
gblnPS = Not (CBool(frmTool.chkPass.Value))
If gblnPS = True Then
gstrDataUser = frmTool.txtName.Text
gstrPassword = frmTool.txtPassword.Text
End If
tmrLoad.Enabled = True
Else
Dim strTemp As String
Dim File_Num As Long
On Error GoTo errNext
File_Num = FreeFile
Open App.Path & "\about.txt" For Binary As #File_Num
strTemp = Input$(LOF(File_Num), #File_Num)
Close #File_Num
Me.Icon = MDIMain.Icon
tmrLoad.Enabled = False
lblTitle.Visible = False
cboName.Enabled = False
txtConceal.Enabled = False
Me.Caption = "关于..."
If gblnPopedom = 1 Then strPopedom = "高级" Else strPopedom = "普通"
txtInfo.Text = strTemp & vbCrLf & " 感谢" & gstrCro & "对本软件的支持!" & vbCrLf & vbCrLf & _
"[用户信息]" & vbCrLf & vbCrLf & " 使用单位: " & gstrCro & vbCrLf & _
" 管理员IP: " & LinkIP & vbCrLf & " 管理级别: " & strPopedom & vbCrLf & " 当前管理员:" & gstrName
strTemp = ""
Exit Sub
errNext:
strTemp = ""
Call ErrMsg(Err.Number, Err.Description)
End If
End Sub
Private Sub loadUser()
On Error GoTo loadErr
With adoLink
intCount = 0
Do Until .EOF
cboName.AddItem .Fields("用户名"), intCount
.MoveNext
intCount = intCount + 1
Loop
If intCount = 0 Then cboName.AddItem "admin", 0
End With
Exit Sub
loadErr:
Call ErrMsg(Err.Number, Err.Description)
End Sub
Private Sub txtConceal_Change()
Dim D As String, e As String, C As Integer
D = " abcdefghijklmnopqrstuvwxyz"
txtPassword.SetFocus
C = Len((txtPassword.Text))
e = Mid(D, C + 1, 1) & (C + 1)
txtConceal.Text = Mid(txtConceal.Text & e, 1, C * 2)
txtConceal.SetFocus
SendKeys "{end}"
End Sub
Private Sub txtConceal_KeyPress(KeyAscii As Integer)
If KeyAscii = 8 Then
If Len(txtPassword.Text) = 0 Then Exit Sub
txtPassword.Text = Mid(txtPassword.Text, 1, Len(txtPassword.Text) - 1)
Else
txtPassword.Text = txtPassword.Text & Chr(KeyAscii)
End If
End Sub
Private Sub txtPassword_GotFocus()
txtConceal.SetFocus
SendKeys "{end}"
End Sub
Private Sub tmrLoad_Timer()
tmrLoad.Enabled = False
Me.Refresh
proBar.Value = 100
Me.Refresh
DoEvents
Call loadOver
End Sub
Sub loadOver()
On Error GoTo ErrLink
gstrLink = gstrNowLink
If Len(gstrLink) = 0 Then gblnLoadError = True: GoTo EndTimer
With adoConn
.CursorLocation = adUseClient
.Open gstrLink
End With
With adoLink
If .State = adStateOpen Then .Close
.Open "select * from 公司信息", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
If .EOF = False Then
gstrCro = .Fields("公司名称") & ""
gstrCroLogo = .Fields("商标") & ""
End If
.Close
.Open "select id from 员工详细资料", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
If .EOF = False Then
.MoveLast
gintManCount = .RecordCount
.MoveFirst
End If
.Close
.Open "select * from 隶属部门", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
If .EOF = False Then
.MoveLast
gintManageCount = .RecordCount
.MoveFirst
End If
.Close
.Open "select * from 系统管理员 order by 用户名", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
End With
EndTimer:
If gblnLoadError = False Then
Me.Hide
imgLogo.Visible = True
proBar.Visible = False
lblTitle.Visible = False
lblName.Visible = True
lblPassword.Visible = True
txtConceal.Visible = True
txtPassword.Visible = True
cmdOK.Visible = True
cmdExit.Visible = True
Me.Height = 4000
Me.Caption = App.Title & " Ver " & App.Major & "." & App.Minor
txtConceal.Enabled = True
Call loadUser
cboName.Visible = True
Me.Show
If cboName.ListCount > 0 Then cboName.ListIndex = 0
txtPassword.SetFocus
Unload frmTool
Else
frmTool.Show
Unload Me
End If
Exit Sub
ErrLink:
gblnLoadError = True
Call ErrMsg(Err.Number, Err.Description & vbCrLf & vbCrLf & vbTab & " 请设置数据库连接或与网络管理员联系!")
GoTo EndTimer
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -