frmlogin.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

        rsGroup.Open sqlExecute, myConn
        If rsGroup.RecordCount = 0 Then
            MsgBox "用户名或密码错误,请重新输入!", vbExclamation, "用户登录"
            Exit Sub
        End If
        If Not IsNull(rsUser.Fields("ID")) Then
            USER_ID = Trim(rsUser.Fields("ID"))
        End If
        If Not IsNull(rsUser.Fields("Name")) Then
            USER_NAME = Trim(rsUser.Fields("Name"))
        End If
        
        If Not IsNull(rsUser.Fields("DOCTOR_Name")) Then
            USER_DISPLAY_NAME = Trim(rsUser.Fields("DOCTOR_Name"))
        End If
        
        '判断用户权限，如果是审核医师，则以普通医师权限登陆
        If Not IsNull(rsUser.Fields("UserPower")) And _
            rsUser.Fields("UserPower") <> POWER_AUDITING_DOCT Then
            USER_POWER = Trim(rsUser.Fields("UserPower"))
        Else
            USER_POWER = POWER_COMMON_USER
        End If
        If Not IsNull(rsUser.Fields("DepartmentId")) Then
            DEPARTMENT_ID = Trim(rsUser.Fields("DepartmentId"))
        End If
        
        DEPARTMENT_NAME = Trim(cmbDepartments.Text)
        If Not IsNull(rsGroup.Fields("POWER")) Then
            DEPARTMENT_POWER = Trim(rsGroup.Fields("POWER"))
        End If
        
        Call SETUSER_INFO(Trim(cmbDepartments.Text))
'*******************************************************************************
        
        
        
        
        Unload Me
        
        frmMdiMain.WindowState = 2
        frmMdiMain.Show
        

    Else
        MsgBox "用户名或密码错误,请重新输入!", vbExclamation, "用户登录"
        txtPassword.Text = ""
        txtPassword.SetFocus
    End If
    
    
    
    
    IF_LOGON = True
    
    
    Exit Sub
ErrHandler:
    If MsgBox(Err.Description + "  您确定要退出吗?", vbExclamation + vbYesNo, "出错") = vbYes Then
        Unload Me
    Else
        Unload Me
        frmLogin.Show vbModal
    End If
       
    IF_LOGON = False
       
       
End Sub
'-----------------------确定按钮事件-----------------------------------------------------------------------------









'部门下拉框--索引改变事件
Private Sub cmbDepartments_Click()
On Error GoTo ErrHandler
    If cmbDepartments.ListCount <= 0 Then
        Exit Sub
    End If
    If Len(Trim(cmbDepartments.Text)) <= 0 Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM Department WHERE NAME = '" + Trim(cmbDepartments.Text) + "'"
    Dim rsCmbDepartment As New ADODB.Recordset
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Sub
    End If
    
    rsCmbDepartment.Open strSql, myConn
    If rsCmbDepartment.RecordCount <> 1 Then
        MsgBox "获取部门ID失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    End If
    If Not IsNull(rsCmbDepartment.Fields("ID")) Then
        DEPARTMENT_ID = Trim(rsCmbDepartment.Fields("ID"))
    End If
    
    cmbUsers.Clear
    Call InitCmbUsers(DEPARTMENT_ID)
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub




Private Sub cmbUsers_Click()
On Error GoTo ErrHandler
    If cmbUserId.ListCount > cmbUsers.ListIndex Then
        cmbUserId.ListIndex = cmbUsers.ListIndex
    End If
    
    txtPassword.Text = ""
    txtPassword.SetFocus
    Exit Sub
ErrHandler:
    'msgbox "",vbExclamation,"提示"
End Sub

Private Sub Form_Load() '登陆系统
On Error GoTo ErrHandler
    

    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.CursorLocation = adUseClient
    myConn.ConnectionString = modGlobalDbConnect.GetConnectionString
    myConn.Open
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Sub
    End If
    
    Dim bRet As Boolean
    bRet = InitCmbDepartment
    If bRet Then
        'If False = InitCmbUsers(DEPARTMENT_ID) Then
        '    MsgBox "请与部门负责人联系进行用户添加!", vbExclamation, "提示"
        '    Exit Sub
        'End If
    Else
        MsgBox "请与系统管理员联系进行部门添加!", vbExclamation, "提示"
    End If
    
    
    Dim dirc As String
    
    Exit Sub
ErrHandler:
    MsgBox "数据库连接失败, 原因：" + Err.Description + "请与系统管理员联系!", vbExclamation, "提示"
    End

End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrHandler
    If myConn.State = adStateOpen Then
        myConn.Close
        Set myConn = Nothing
    End If
    Exit Sub
ErrHandler:

End Sub


'初始化部门下拉框
Private Function InitCmbDepartment() As Boolean
On Error GoTo ErrHandler
    cmbDepartments.Clear
    
    Dim strSql As String
    strSql = "SELECT ID, NAME  FROM DEPARTMENT  WHERE POWER<='100'"
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Function
    End If
    
    rsDepartment.Open strSql, myConn
    If rsDepartment.RecordCount <= 0 Then
        InitCmbDepartment = False
        Exit Function
    End If
    
    Dim i As Integer
    
    For i = 0 To rsDepartment.RecordCount - 1
        cmbDepartments.AddItem rsDepartment.Fields("Name")
        rsDepartment.MoveNext
    Next
    
    If cmbDepartments.ListCount > 0 Then
        cmbDepartments.ListIndex = 0

    End If

    InitCmbDepartment = True
    Exit Function
ErrHandler:
    Debug.Print Err.Description
    InitCmbDepartment = False
End Function

'根据部门ID初始化用户COMBOBOX
Private Function InitCmbUsers(ByVal DepartmentID As Long) As Boolean
On Error GoTo ErrHandler
    Dim strSql As String
    Dim rsCmbUsers As New ADODB.Recordset
    
    
    'id = ""
    'If id = "" Then
    '    strSql = "select "
    'End If
    
    
    strSql = "SELECT ID,NAME FROM Doctor  WHERE DepartmentId = '" + CStr(DepartmentID) + "'" + " AND ISDELETE ='否'"
    
    
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Function
    End If
    
    rsCmbUsers.Open strSql, myConn
    
    If rsCmbUsers.RecordCount <= 0 Then
        InitCmbUsers = False
        Exit Function
    End If
    
    Dim i As Integer
    cmbUserId.Clear
    cmbUsers.Clear
    For i = 0 To rsCmbUsers.RecordCount - 1
        cmbUserId.AddItem rsCmbUsers.Fields("ID")
        cmbUsers.AddItem rsCmbUsers.Fields("Name")
        rsCmbUsers.MoveNext
    Next
    
    If cmbUsers.ListCount > 0 And cmbUserId.ListCount > 0 Then
        cmbUsers.ListIndex = 0
        cmbUserId.ListIndex = 0
    End If
    
    InitCmbUsers = True
    Exit Function
ErrHandler:
    Debug.Print Err.Description
    InitCmbUsers = False
End Function




Private Sub Form_KeyPress(KeyAscii As Integer)
    '回车键
    If KeyAscii = 13 Then
        btnOk_Click 0
    End If
End Sub