module1.bas

宾馆管理系统 宾馆管理系统 宾馆管理系统

Attribute VB_Name = "Module1"
Public Uid As String
Public Pwd As String
Public UName As String

Public fMainForm As frmMain

Public flagTedit As Boolean
Public flagRedit As Boolean
Public flagBedit As Boolean
Public flagCedit As Boolean
Public flagSedit As Boolean

Public gintCmode As Integer
Public gintTmode As Integer
Public gintRmode As Integer
Public gintBmode As Integer

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.sbStatusBar.Panels(1).Text = "当前用户:" & UName & " 当前登陆代码: " & Module1.Uid
    If Module1.Uid <> "sa" Then
       fMainForm.mnuYhgl = False
     End If
    fMainForm.Show
End Sub
Public Function ConnectString() As String
    ConnectString = "provider=SQLOLEDB;Initial Catalog=hotel;data source=(local);user id=" & Uid & ";password=" & Pwd
    '连接字符串的vb语句
End Function
Public Function ExecuteSQL(ByVal SQL As String, MsgString As String) As ADODB.Recordset
    'byval 值传递
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sTokens() As String
    'stokens是一个数组
    
    On Error GoTo ExecuteSQL_Error
    
    sTokens = Split(SQL)
    Set cnn = New ADODB.Connection
    cnn.Open ConnectString
    '调用ConnectString函数,与数据库连接
    If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then
       cnn.Execute SQL
       '当传入的SQL为INSERT,DELETE,UPDATE时,执行命令
       MsgString = sTokens(0) & "query successful"
    Else
       Set rst = New ADODB.Recordset
       rst.Open Trim$(SQL), cnn, adOpenKeyset, adLockOptimistic
       Set ExecuteSQL = rst
       MsgString = "查询到" & rst.RecordCount & " 条记录"
    End If
ExecuteSQL_Exit:
    Set rst = Nothing
    Set cnn = Nothing
    Exit Function
ExecuteSQL_Error:
    MsgString = "查询错误:" & Err.Description
    Resume ExecuteSQL_Exit
    
End Function
Public Function Checkpwd() As Boolean
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
   
    Set cnn = New ADODB.Connection
    'On Error GoTo Check_Error
   
    cnn.Open ConnectString
    Set rs = New ADODB.Recordset
    
    rs.Open "select user_name()", cnn
    '返回当前数据库的用户名
    
    UName = rs.Fields(0).Value
   ' MsgBox UName
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
    Checkpwd = True
    Exit Function

Check_Error:
    'Err.Raise Err.Number, , Err.Description
    Set cnn = Nothing
    Checkpwd = False
End Function
Public Sub Modifypwd(newpwd As String)
    Dim cnn As ADODB.Connection
    Dim sqlStr As String
    Set cnn = New ADODB.Connection
    On Error GoTo ExecuteSQL_Error
    cnn.Open ConnectString
    
    If Trim(Pwd) = "" Then
       sqlStr = "exec sp_password null" & ",'" & newpwd & "','" & Uid & "'"
    Else
       sqlStr = "exec sp_password '" & Pwd & "','" & newpwd & "'"
    End If
    cnn.Execute sqlStr
    Exit Sub
ExecuteSQL_Error:
    MsgBox Err.Description, vbCritical, "错误"
    Set cnn = Nothing
End Sub
Public Sub AddUser(loginName As String, userPwd As String, userName As String)
    Dim cnn As ADODB.Connection
    Dim sqlStr As String
    Set cnn = New ADODB.Connection
    On Error GoTo ExecuteSQL_Error
    cnn.Open ConnectString
    
    'MsgBox loginName + userPwd + userName
    
    sqlStr = "exec sp_addlogin '" & loginName & "','" & userPwd & "','hotel'"
    cnn.Execute sqlStr
    '为hotel数据库添加用户
    sqlStr = "exec sp_adduser '" & loginName & "','" & userName & "'"
    cnn.Execute sqlStr
    '为登陆数据库添加用户
    
    '为用户对bookin,rooms,roomtype分配权限
    sqlStr = "grant all privileges on bookin to " & userName
    sqlStr = sqlStr & " with grant option"
    cnn.Execute sqlStr
    
    sqlStr = "grant all privileges on rooms to " & userName
    sqlStr = sqlStr & " with grant option"
    cnn.Execute sqlStr
    
    sqlStr = "grant all privileges on roomtype to " & userName
    sqlStr = sqlStr & "  with grant option"
    cnn.Execute sqlStr
    Exit Sub
ExecuteSQL_Error:
    Err.Raise Err.Number, , Err.Description
    Set cnn = Nothing
End Sub

Public Sub ListUser(myms As MSFlexGrid)
    Dim cnn As ADODB.Connection
    Dim sqlStr As String
    Dim rs As New ADODB.Recordset
    Set cnn = New ADODB.Connection
    Dim i As Integer
    cnn.Open ConnectString
    
    myms.Clear
    myms.Row = 2
    myms.TextMatrix(0, 0) = "登陆代码"
    myms.TextMatrix(0, 1) = "用户名"
    On Error GoTo checkerror
    
    rs.Open "exec sp_helpuser", cnn
    myms.TextMatrix(1, 0) = rs.Fields("loginname").Value
    myms.TextMatrix(1, 1) = rs.Fields("username").Value
    rs.MoveNext
    
    i = 1
    Do While Not (rs.EOF)
       i = i + 1
       myms.Row = myms.Row + 1
       myms.TextMatrix(i, 0) = rs.Fields("loginname").Value
       myms.TextMatrix(i, 1) = rs.Fields("username").Value
       rs.MoveNext
    Loop
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Exit Sub
checkerror:
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Err.Raise Err.Number, , Err.Description
    
End Sub
Public Sub DeleteUser(loginName As String, userName As String)
    Dim cnn As ADODB.Connection
    Dim sqlStr As String
    
    Set cnn = New ADODB.Connection
    On Error GoTo checkerror
    Dim i As Integer
    cnn.Open ConnectString
    
    cnn.Execute "exec sp_dropuser " & userName
    cnn.Execute "exec sp_droplogin '" & loginName & "'"
    Set cnn = Nothing
    Exit Sub
checkerror:
    Set cnn = Nothing
    Err.Raise Err.Number, , Err.Description
    
    
End Sub