ihms_usermgt.frm

医院小型HIS信息管理系统

VERSION 5.00
Begin VB.Form frmUserMgt 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "操作员管理"
   ClientHeight    =   5220
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4920
   Icon            =   "IHMS_UserMgt.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5220
   ScaleWidth      =   4920
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdClose 
      Caption         =   "退出(&E)"
      Height          =   495
      Left            =   480
      TabIndex        =   3
      Top             =   4320
      Width           =   3855
   End
   Begin VB.Data datUsers 
      Caption         =   "Users"
      Connect         =   "Access"
      DatabaseName    =   ""
      DefaultCursorType=   0  '缺省游标
      DefaultType     =   2  '使用 ODBC
      Exclusive       =   0   'False
      Height          =   345
      Left            =   1080
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   ""
      Top             =   4680
      Visible         =   0   'False
      Width           =   2940
   End
   Begin VB.Frame Frame1 
      Caption         =   "用户列表"
      Height          =   3975
      Left            =   480
      TabIndex        =   0
      Top             =   240
      Width           =   3855
      Begin VB.CommandButton cmdChangePassword 
         Caption         =   "更改密码"
         Height          =   495
         Left            =   240
         TabIndex        =   5
         Top             =   3240
         Width           =   3375
      End
      Begin VB.CommandButton cmdAddUser 
         Caption         =   "新增用户"
         Height          =   495
         Left            =   240
         TabIndex        =   4
         Top             =   2640
         Width           =   1575
      End
      Begin VB.CommandButton cmdDeleteUser 
         Caption         =   "删除用户"
         Height          =   495
         Left            =   2040
         TabIndex        =   2
         Top             =   2640
         Width           =   1575
      End
      Begin VB.ListBox lstUsers 
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   1860
         Left            =   240
         Sorted          =   -1  'True
         TabIndex        =   1
         Top             =   360
         Width           =   3375
      End
   End
End
Attribute VB_Name = "frmUserMgt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
' ：） 人人为我，我为人人 ：）
'枕善居汉化收藏整理
'发布日期：06/02/21
'描    述：智能医院管理系统  Version 1.0
'网    站：http://www.mndsoft.com/
'e-mail  ：[e-mail]
'OICQ    ：88382850
'****************************************************************************
Option Explicit

Private Sub cmdAddUser_Click()
 Dim userName As String
 Dim passPhrase As String
 
 userName = InputBox("Enter a user name:")
 passPhrase = InputBox("Enter a password for the user:")
 If Trim(userName = "") Or Trim(passPhrase = "") Then
    MsgBox "User name AND password have to be of non-zero lenght. Try again", , "Error"
    Exit Sub
 End If
 lstUsers.AddItem UCase(userName)
 With datUsers.Recordset
    .AddNew
    .Fields("user") = userName
    .Fields("pass") = passPhrase
    .Update
 End With
 MsgBox "New User successfully added."
End Sub

Private Sub cmdChangePassword_Click()
 On Error GoTo errhnd
 Dim oldPass As String
 Dim newPass As String
 Dim confirmPass As String
 
 With datUsers.Recordset
    .MoveFirst
    Do While UCase(.Fields("user")) <> lstUsers.List(lstUsers.ListIndex)
        .MoveNext
    Loop
    oldPass = InputBox("Enter the old password:")
    newPass = InputBox("Enter the new password:")
    confirmPass = InputBox("Confirm new password:")
    If UCase(oldPass) = UCase(.Fields("pass")) Then
        If newPass = confirmPass Then
            .Edit
            .Fields("pass") = newPass
            .Update
            MsgBox "Password change successful!"
        Else
            MsgBox "Password change failed! Please retry", vbInformation
        End If
    Else
        MsgBox "Old password incorrect. Please retry"
    End If
 End With
 Exit Sub
errhnd:
 Select Case Err.Number
 Case 3021
    MsgBox "You need to select a user to update"
 Case Else
    MsgBox "Critical error"
 End Select

End Sub

Private Sub cmdClose_Click()
 Unload Me
End Sub

Private Sub cmdDeleteUser_Click()
 On Error GoTo errhnd
 If MsgBox("Sure you want to delete this user?", vbYesNo, "Confirm") = vbNo Then Exit Sub
 
 With datUsers.Recordset
    .MoveFirst
    Do While UCase(.Fields("user")) <> lstUsers.List(lstUsers.ListIndex)
        .MoveNext
    Loop
    If UCase(lstUsers.List(lstUsers.ListIndex)) = "DOCTOR" Then
        MsgBox "The DOCTOR account is an administrative account and CANNOT be deleted!"
        Exit Sub
    End If
    .Delete
    lstUsers.RemoveItem lstUsers.ListIndex
 End With
Exit Sub

errhnd:
 Select Case Err.Number
 Case 3021
    MsgBox "You need to select a user to delete"
 Case Else
    MsgBox "Critical error"
 End Select
End Sub

Private Sub Form_Load()

'On Error Resume Next
 datUsers.DatabaseName = App.Path & "\IHMS_97.mdb"
 datUsers.RecordSource = "IHMS_Users"
 datUsers.Refresh
 
 'populate lstUsers
 With datUsers.Recordset
    .MoveFirst
    Do While Not .EOF
        lstUsers.AddItem (UCase(.Fields("user")))
        .MoveNext
    Loop
 End With
 
End Sub