我做的是客户端服务器程序,通过sql密码认证的,我给你们你们还得做数据库啊,代码有点多。
下面的是模块里面的
Option Explicit
Public fMainForm As New frmMain
Public State As Boolean
Public Username As String
Sub Main()
Dim fLogin As New frmLogin
fLogin.Show vbModal
If Not fLogin.Ok Then
End
End If
Unload fLogin
Set fMainForm = New frmMain
fMainForm.Show
End SubPublic Function ExecuteSQL(ByVal SQL As String, MsgString As String) As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
'定义字符串
Dim sTokens() As String
State = True
On Error GoTo ExecuteSQL_Error
'用Split 函数来产生一个包含各个子串的数组
sTokens = Split(SQL)
Set cnn = New ADODB.Connection
cnn.Open ConnectString
If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then
cnn.Execute SQL
MsgString = sTokens(0) & "query successful"
Else
Set rst = New ADODB.Recordset
rst.Open SQL, cnn, adOpenDynamic, adLockBatchOptimistic
Set ExecuteSQL = rst
MsgString = "查询到" & rst.RecordCount & "条记录"
End IfExecuteSQL_Exit:
'清空数据集对象
Set rst = Nothing
'中断连接
Set cnn = Nothing
Exit Function
ExecuteSQL_Error:
MsgString = "查询错误:" & Err.Description
MsgBox "你没有连接到服务器上,请与管理员联系", vbOKOnly + vbExclamation, "警告"
State = False
'Debug.Print Err.Description
Resume ExecuteSQL_ExitEnd FunctionPublic Function ConnectString() As String
ConnectString = "File Name=c:\Program Files\Common Files\ODBC\Data Sources\HTK.dsn;"End Function
在下面是登录窗口的代码
Option Explicit
Public Ok As Boolean
Dim miCount As IntegerPrivate Sub cboItem_Click()
Username = Trim(cboItem)
End SubPrivate Sub cmdCancel_Click()
Ok = False
Me.Hide
End SubPrivate Sub cmdOk_Click()
Dim txtSQL As String
Dim MsgText As String
Username = ""
Dim mrc As ADODB.Recordset
txtSQL = "select user_PWD from user_Info where user_ID='" & Trim(cboItem) & "'"
Set mrc = ExecuteSQL(txtSQL, MsgText)
If State = False Then
Exit Sub
End IfIf txtPWD <> Trim(mrc.Fields(0)) Then
MsgBox "输入的密码错误,请重新输入!", vbOKOnly + vbExclamation, "警告"
txtPWD.Text = ""
txtPWD.SetFocus
mrc.Close
End IfmiCount = miCount + 1
If miCount = 3 Then
Me.Hide
End If
Exit Sub
End SubPrivate Sub Form_Load()
Dim txtSQL As String
Dim MsgText As String
Dim mrc As ADODB.Recordset
txtSQL = "select user_ID from user_Info"
Set mrc = ExecuteSQL(txtSQL, MsgText)
If Not mrc.EOF Then
Do While Not mrc.EOF
cboItem.AddItem Trim(mrc.Fields(0))
mrc.MoveNext
Loop
cboItem.ListIndex = 0
Else
MsgBox "请与管理员联系取得用户名", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
mrc.Close
Ok = False
miCount = 0
End Sub
登录窗口上有一个list下拉列表框,有一个文本框,还有两个按钮,一个是确认,一个是取消按钮。就这么多!
如果还不清楚,可以把你们的邮箱告诉我,我把源代码发给你!
下面的是模块里面的
Option Explicit
Public fMainForm As New frmMain
Public State As Boolean
Public Username As String
Sub Main()
Dim fLogin As New frmLogin
fLogin.Show vbModal
If Not fLogin.Ok Then
End
End If
Unload fLogin
Set fMainForm = New frmMain
fMainForm.Show
End SubPublic Function ExecuteSQL(ByVal SQL As String, MsgString As String) As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
'定义字符串
Dim sTokens() As String
State = True
On Error GoTo ExecuteSQL_Error
'用Split 函数来产生一个包含各个子串的数组
sTokens = Split(SQL)
Set cnn = New ADODB.Connection
cnn.Open ConnectString
If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then
cnn.Execute SQL
MsgString = sTokens(0) & "query successful"
Else
Set rst = New ADODB.Recordset
rst.Open SQL, cnn, adOpenDynamic, adLockBatchOptimistic
Set ExecuteSQL = rst
MsgString = "查询到" & rst.RecordCount & "条记录"
End IfExecuteSQL_Exit:
'清空数据集对象
Set rst = Nothing
'中断连接
Set cnn = Nothing
Exit Function
ExecuteSQL_Error:
MsgString = "查询错误:" & Err.Description
MsgBox "你没有连接到服务器上,请与管理员联系", vbOKOnly + vbExclamation, "警告"
State = False
'Debug.Print Err.Description
Resume ExecuteSQL_ExitEnd FunctionPublic Function ConnectString() As String
ConnectString = "File Name=c:\Program Files\Common Files\ODBC\Data Sources\HTK.dsn;"End Function
在下面是登录窗口的代码
Option Explicit
Public Ok As Boolean
Dim miCount As IntegerPrivate Sub cboItem_Click()
Username = Trim(cboItem)
End SubPrivate Sub cmdCancel_Click()
Ok = False
Me.Hide
End SubPrivate Sub cmdOk_Click()
Dim txtSQL As String
Dim MsgText As String
Username = ""
Dim mrc As ADODB.Recordset
txtSQL = "select user_PWD from user_Info where user_ID='" & Trim(cboItem) & "'"
Set mrc = ExecuteSQL(txtSQL, MsgText)
If State = False Then
Exit Sub
End IfIf txtPWD <> Trim(mrc.Fields(0)) Then
MsgBox "输入的密码错误,请重新输入!", vbOKOnly + vbExclamation, "警告"
txtPWD.Text = ""
txtPWD.SetFocus
mrc.Close
End IfmiCount = miCount + 1
If miCount = 3 Then
Me.Hide
End If
Exit Sub
End SubPrivate Sub Form_Load()
Dim txtSQL As String
Dim MsgText As String
Dim mrc As ADODB.Recordset
txtSQL = "select user_ID from user_Info"
Set mrc = ExecuteSQL(txtSQL, MsgText)
If Not mrc.EOF Then
Do While Not mrc.EOF
cboItem.AddItem Trim(mrc.Fields(0))
mrc.MoveNext
Loop
cboItem.ListIndex = 0
Else
MsgBox "请与管理员联系取得用户名", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
mrc.Close
Ok = False
miCount = 0
End Sub
登录窗口上有一个list下拉列表框,有一个文本框,还有两个按钮,一个是确认,一个是取消按钮。就这么多!
如果还不清楚,可以把你们的邮箱告诉我,我把源代码发给你!
fLogin.Show vbModal
If Not fLogin.Ok Then
End
End If
进去然后就出不来了?
当执行到flogin.show vbmodal时就不出来了。还没有执行下面的if 语句呢!
是这样的,当执行到flogin.show vbmodal去执行登录窗口,如果密码确认完毕再回到main()函数中去,但是现在就是确认了密码密码正确的也回不去啊。
exit sub只是退出了当前过程,并没有关闭模式窗口,程序停在那里等待事件,后面的代码当然不能运行。
就是说flogin.show vbmodal的时候,Sub Main()就暂停了,而将flogin压栈,然后一直到你点击cmdOk或cmdCancel,这个时候如果你只是将flogin.hide,flogin并没有退栈,所以Sub Main()依然没有回到栈顶,自然就不执行了。
所以你在cmdok_click或是在cmdCancel_click的时候,你要unload me,也就是说将flogin从堆栈中退出,这样sub main()就重新回到栈顶继续执行了。