📄 frmlogin.frm
字号:
VERSION 5.00
Begin VB.Form frmLogin
BorderStyle = 1 'Fixed Single
Caption = "餐饮系统登录"
ClientHeight = 2595
ClientLeft = 45
ClientTop = 330
ClientWidth = 4260
Icon = "frmLogin.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
Moveable = 0 'False
ScaleHeight = 2595
ScaleWidth = 4260
StartUpPosition = 2 '屏幕中心
Tag = "Login"
Begin VB.Frame famlogin
BackColor = &H00A56E3A&
Height = 2175
Left = 0
TabIndex = 2
Top = -60
Width = 4275
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 210
Left = 90
TabIndex = 11
Top = 1515
Width = 375
End
Begin VB.ComboBox cbocompany
Appearance = 0 'Flat
BackColor = &H00C0FFFF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 1620
TabIndex = 9
Top = 960
Width = 2355
End
Begin VB.TextBox txtPassword
Appearance = 0 'Flat
BackColor = &H00C0FFFF&
BeginProperty Font
Name = "Fixedsys"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
IMEMode = 3 'DISABLE
Left = 1620
PasswordChar = "*"
TabIndex = 6
Top = 600
Width = 2325
End
Begin VB.ComboBox cobusername
Appearance = 0 'Flat
BackColor = &H00C0FFFF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 1620
TabIndex = 5
Top = 180
Width = 2355
End
Begin VB.CommandButton cmdOK
Appearance = 0 'Flat
Height = 450
Left = 780
Picture = "frmLogin.frx":030A
Style = 1 'Graphical
TabIndex = 4
Top = 1500
Width = 1455
End
Begin VB.CommandButton cmdCancel
Appearance = 0 'Flat
Height = 450
Left = 2400
Picture = "frmLogin.frx":0AD1
Style = 1 'Graphical
TabIndex = 3
Top = 1500
Width = 1455
End
Begin VB.Label Label3
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "帐 套"
Height = 195
Left = 645
TabIndex = 10
Top = 1080
Width = 735
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "密 码"
Height = 195
Left = 525
TabIndex = 8
Top = 660
Width = 855
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "操 作 员"
Height = 195
Left = 660
TabIndex = 7
Top = 300
Width = 735
End
Begin VB.Shape Shape1
BackColor = &H00C0FFFF&
FillColor = &H00C0FFFF&
FillStyle = 0 'Solid
Height = 285
Left = 600
Top = 240
Width = 855
End
Begin VB.Shape Shape2
BackColor = &H00C0FFFF&
FillColor = &H00C0FFFF&
FillStyle = 0 'Solid
Height = 285
Left = 600
Top = 615
Width = 855
End
Begin VB.Shape Shape3
BackColor = &H00C0FFFF&
FillColor = &H00C0FFFF&
FillStyle = 0 'Solid
Height = 285
Left = 600
Top = 1020
Width = 855
End
End
Begin VB.PictureBox PicCaption
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 720
Left = 1440
Picture = "frmLogin.frx":12AB
ScaleHeight = 720
ScaleWidth = 9600
TabIndex = 0
TabStop = 0 'False
Top = 2580
Visible = 0 'False
Width = 9600
Begin VB.PictureBox PicBorder
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 150
Left = 0
Picture = "frmLogin.frx":17AEF
ScaleHeight = 150
ScaleWidth = 1050
TabIndex = 1
TabStop = 0 'False
Top = 0
Visible = 0 'False
Width = 1050
End
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 strsql As String
Private i As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub cbocompany_Click()
Call Initcobusername
End Sub
Private Sub Command1_Click()
Dim s As String
Dim rs1 As New ADODB.Recordset
s = "select ylid from ylmcb"
Set rs1 = GetRsBySQL(s)
Do While Not rs1.EOF
s = "insert into kcb values('" & rs1.Fields(0) & "',0,0,100)"
Call ExeSQLByCmd(s)
rs1.MoveNext
Loop
End Sub
Private Sub Form_Load()
On Error Resume Next
'///////试用日期检测
Dim d1 As String
d1 = Chr(50) & Chr(48) & Chr(48) & Chr(51)
d1 = d1 & "-05-05"
If Format(Date, "yyyy-mm-dd") > d1 Then
MsgBox "对不起，软件试用期己过！！"
End
Unload Me
End If
Dim sBuffer As String
Dim lSize As Long
DBServerName = ""
DBUserName = ""
DBPassword = ""
DBName = ""
DBServerName = GetINIFile("DBInfo", "DBServerName")
DBUserName = GetINIFile("DBInfo", "DBUserName")
DBPassword = GetINIFile("DBInfo", "DBPassword")
DBName = GetINIFile("DBInfo", "DBName")
' MsgBox DBServerName
' MsgBox DBUserName
' MsgBox DBPassword
' MsgBox DBName
If DBServerName <> "" And DBUserName <> "" And DBName <> "" Then
' 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
Skin Me, m_cN
Call Initcbocompany
Else
MsgBox "数据库还没有配置,请先配置您的数据库!", vbInformation, "警告"
End
End If
Call Initcobusername
End Sub
Private Sub Initcbocompany()
On Error Resume Next
Dim rs As ADODB.Recordset
Dim strsql As String
Dim i As Long
strsql = "select * from companys"
Set rs = GetRsBySQL(strsql)
If rs.RecordCount = 0 Then Exit Sub
With cbocompany
.Clear
For i = 0 To rs.RecordCount - 1
.AddItem rs("company_name")
rs.MoveNext
Next
.Text = .List(0)
End With
rs.Close
Set rs = Nothing
End Sub
Private Sub Initcobusername()
On Error Resume Next
Dim rs As ADODB.Recordset
strsql = "select employee_id from employees,companys where company_name='"
strsql = strsql & cbocompany & "' and companys.company_id=employees.company_id order by employee_id"
Set rs = GetRsBySQL(strsql)
If rs.RecordCount = 0 Then Exit Sub
cobusername.Clear
For i = 0 To rs.RecordCount - 1
With cobusername
.AddItem rs("employee_id")
End With
rs.MoveNext
Next
cobusername = cobusername.List(0)
rs.Close
Set rs = Nothing
End Sub
Private Sub cmdCancel_Click()
Unload frmLogin
End Sub
Private Sub cmdOK_Click()
'ToDo: create test for correct password
'check for correct password
On Error Resume Next
Dim dKey As Double
Dim dTime As Double
Dim strmsg As String
Dim rs As ADODB.Recordset
Dim strsql As String
strsql = "select company_id from companys where company_name='" & cbocompany & "'"
Set rs = GetRsBySQL(strsql)
If rs.RecordCount = 0 Then Exit Sub
g_companyid = rs("company_id")
rs.Close
Set rs = Nothing
g_susername = cobusername
If ValidateUser(g_susername, txtPassword) Then
Unload frmLogin
frmMain.Show
Else
MsgBox "您输入的密码错误,请您重新输入!", vbInformation, "用户登录"
txtPassword.SetFocus
txtPassword.SelStart = 0
txtPassword.SelLength = Len(txtPassword.Text)
End If
End Sub
Private Sub txtPassword_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = KEY_ENTER Then
Call cmdOK_Click
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -