frmsystemmaintain.frm

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

    End If
    
    '科室主任
    If modUserInfo.USER_POWER = POWER_DEPARTMENT_LEADER Then
        strSql = strSql + " and Department.Name = '" + CStr(DEPARTMENT_NAME) + "'"
    End If
    
    
    lstUserId.Clear
    
    If rsUser.State = adStateOpen Then
        rsUser.Close
    End If
    
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Sub
    End If
    
    rsUser.Open strSql, myConn
    Dim i As Long
    For i = 0 To rsUser.RecordCount - 1
        If Not IsNull(rsUser.Fields("Doctor_Name")) Then
            lstUserId.AddItem rsUser.Fields("Doctor_Name")
        End If
        
        
        rsUser.MoveNext
    Next
    
    
    txtDoctorId.Text = ""
    txtDoctorName.Text = ""
    txtDoctorPost.Text = ""
    
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub


'用户管理----单击部门下拉匡
Private Sub cmbDepartments_Click()
On Error GoTo ErrHandler
    cmbDepartments_ID.ListIndex = cmbDepartments.ListIndex
    Call InitDoctorListBox
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub





'
Private Sub Form_Activate()
On Error GoTo ErrHandler
    
    Dim bRet As Boolean
    '系统管理员
    If USER_POWER = POWER_ADMIN Then
        bRet = InitCmbDepartment
        If Not bRet Then
            MsgBox "部门下拉框初始化失败, 请与系统管理员联系!", vbExclamation, "提示"
            Exit Sub
        End If
        Call InitDoctorListBox
        
        Call InitDepartmentListBox
        Call InitCmbPower(USER_POWER)
        
        lblUserAdminDept.Visible = True
        cmbDepartments.Visible = True
    '科室主任
    ElseIf USER_POWER = POWER_DEPARTMENT_LEADER Then
        '科室主任登陆时，部门下拉框不可见
        Call InitDoctorListBox
        
        Call InitCmbPower(USER_POWER)
        
        lblUserAdminDept.Visible = False
        cmbDepartments.Visible = False
        '科室主任只能添加本科室的普通医师
        'If cmbPower.ListCount > 3 Then
        '    cmbPower.ListIndex = 3
        'End If
        'cmbPower.Enabled = False
    End If
    
    
    tabSystemMaintain.Tab = 0
    
    Exit Sub
ErrHandler:
    MsgBox "数据库连接失败, 原因:" + Err.Description, vbExclamation, "提示"
    
End Sub



Private Sub Form_Load()
    '医生，密码，职称，权限
    On Error GoTo ErrHandler

    
    '普通用户，只显示密码修改界面
    If modUserInfo.USER_POWER = POWER_COMMON_USER Then
        tabSystemMaintain.TabVisible(0) = True
        tabSystemMaintain.TabVisible(1) = False
        tabSystemMaintain.TabVisible(2) = False
        'tabSystemMaintain.TabVisible(3) = False
    '科室主任，部门管理界面不显示
    ElseIf modUserInfo.USER_POWER = POWER_DEPARTMENT_LEADER Then
        tabSystemMaintain.TabVisible(2) = False
        'tabSystemMaintain.TabVisible(3) = False
    '系统管理员，机器管理不显示
    ElseIf modUserInfo.USER_POWER = POWER_ADMIN Then
        'tabSystemMaintain.TabVisible(3) = False
        
    Else
        tabSystemMaintain.TabVisible(0) = True
        tabSystemMaintain.TabVisible(1) = False
        tabSystemMaintain.TabVisible(2) = False
        'tabSystemMaintain.TabVisible(3) = False
    End If
    
    
    myConn.CursorLocation = adUseClient
    If myConn.State = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    Exit Sub
ErrHandler:
    MsgBox "数据库连接失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub



Private Sub Form_Resize()
On Error Resume Next
    Me.Top = frmSubTop.Top + frmSubTop.Height
    Me.left = frmSubLeft.Width + frmSubLeft.left
    Me.Width = RIGHT_WINDOW_WIDTH
    Me.Height = RIGHT_WINDOW_HEIGHT
    
    
    Me.tabSystemMaintain.Width = Me.Width - 2 * Me.tabSystemMaintain.left
    Me.tabSystemMaintain.Height = Me.Height - 2 * Me.tabSystemMaintain.Top ' - btnBack.Height * 2
    'btnBack.top = Me.tabSystemMaintain.top + Me.tabSystemMaintain.Height + btnBack.Height / 2
    
    Me.picPassword.Width = Me.tabSystemMaintain.Width
    Me.picUserAdmin.Width = Me.tabSystemMaintain.Width
    Me.picDepartmentAdmin.Width = Me.tabSystemMaintain.Width
    'Me.picMachineAdmin.Width = Me.tabSystemMaintain.Width
    
    Me.picPassword.Height = Me.tabSystemMaintain.Height - Me.picPassword.Top
    Me.picUserAdmin.Height = Me.picPassword.Height
    Me.picDepartmentAdmin.Height = Me.picPassword.Height
    'Me.picMachineAdmin.Height = Me.picPassword.Height
    
End Sub

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

'初始化部门下拉框
Private Function InitCmbDepartment() As Boolean
On Error GoTo ErrHandler
    cmbDepartments_ID.Clear
    cmbDepartments.Clear
    
    Dim strSql As String
    strSql = "SELECT ID, NAME  FROM Department WHERE NAME <> '" _
        + CStr(DEPARTMENT_ADMIN_NAME) + "'"
    
    Dim rsCmbDepartment As New ADODB.Recordset
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Function
    End If
    
    rsCmbDepartment.Open strSql, myConn
    If rsCmbDepartment.RecordCount <= 0 Then
        InitCmbDepartment = False
        Exit Function
    End If

    Dim i As Integer
    
    
    'If Not IsNull(rsCmbDepartment.Fields("ID")) Then
        'DEPARTMENT_ID = rsCmbDepartment.Fields("ID")
    '    cmbDepartments_ID = rsCmbDepartment.Fields("ID")
    'End If
    
    For i = 0 To rsCmbDepartment.RecordCount - 1
        If Not IsNull(rsCmbDepartment.Fields("Name")) And Not IsNull(rsCmbDepartment.Fields("ID")) Then
            cmbDepartments.AddItem (rsCmbDepartment.Fields("Name"))
            cmbDepartments_ID.AddItem (rsCmbDepartment.Fields("ID"))
            'cmbDepartments_ID.ListIndex = cmbDepartments.ListIndex
        
        End If
        rsCmbDepartment.MoveNext
    Next
    
    If cmbDepartments.ListCount > 0 Then
        cmbDepartments.ListIndex = 0

    End If

    InitCmbDepartment = True
    If USER_POWER = POWER_DEPARTMENT_LEADER Then
        cmbDepartments.Enabled = False
    Else
        cmbDepartments.Enabled = True
    End If
    Exit Function
ErrHandler:
    Debug.Print Err.Description
    InitCmbDepartment = False
    MsgBox Err.Description, vbExclamation, "提示"
End Function

'==部门管理================================================================
'修改部门
Private Sub btnModifyDepartment_Click(Shifit As Integer)
On Error GoTo ErrHandler
    If Trim(txtDepartmentName.Text) = "" Then
        MsgBox "请选择要修改的部门!", vbExclamation, "提示"
        Exit Sub
    End If

    If stringCheck(Trim(txtDepartmentName.Text)) = False Then
        Exit Sub
    End If
    
    Dim DPower As Integer
    If optPhoto.Value = True Then
        DPower = POWER_DEPARTMENT_LEADER
    End If
    
    If optNoPhoto.Value = True Then
        DPower = POWER_COMMON_USER
    End If
    
    
    Dim strSelectSql As String
    strSelectSql = " SELECT NAME FROM Department WHERE NAME = '" + Trim(txtDepartmentName.Text) + "'" _
        + " AND POWER = '" + CStr(DPower) + "'"
    If Not GetRecordNumber(strSelectSql) = 0 Then
        MsgBox "该部门已经存在！", vbExclamation, "提示"
        Exit Sub
    End If
    
    
    If MsgBox(Err.Description + "  您确定要修改吗?", vbYesNo Or vbQuestion, "提示") <> vbYes Then
        Exit Sub
    End If
    
    
    Dim strUpDateSql As String
    
    strUpDateSql = " UPDATE Department SET NAME ='" + Trim(txtDepartmentName.Text) + "'," _
    + "POWER = '" + CStr(DPower) + "' WHERE ID = '" + CStr(curID) + "'"
    
    '===事务处理开始====================================================
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Sub
    End If
    
    myConn.BeginTrans '开始
    '执行语句
    myConn.Execute strUpDateSql
    If Err.Number = 0 Then
        myConn.CommitTrans '---提交事務
        MsgBox "<部门>修改成功.", vbExclamation, "提示"
    Else
        myConn.RollbackTransaction
        MsgBox "<部门>修改失败!", vbExclamation, "提示"
    End If
    '===事务处理结束====================================================
    
    Call InitDepartmentListBox
    Call InitCmbDepartment
    
    
    txtDepartmentName.Text = ""
    optPhoto = True
    optNoPhoto = False
   Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub


'部门管理----删除部门
Private Sub btnDeleteDepartment_Click(Shifit As Integer)
On Error GoTo ErrHandler
    Dim strCurDptName As String
    
    'dgDepartment
    '0      编号
    '1      部门名称
    strCurDptName = lstDepartment.Text
    
    
    If Trim(txtDepartmentName.Text) = "" Or Trim(strCurDptName) = "" Then
        MsgBox "请选择要删除的部门!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If MsgBox("部门删除不可恢复，且该部门所属的医师都将被删除，您确定要删除部门<" _
        + Trim(txtDepartmentName.Text) + ">吗?", _
        vbYesNo Or vbQuestion, "提示") <> vbYes Then
        Exit Sub
    End If
    
    Dim strDeleteSql As String
    strDeleteSql = "DELETE FROM Department WHERE Name = '" + CStr(strCurDptName) + "'"
    
    '===事务处理开始====================================================
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    If myConn.State = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        Exit Sub
    End If
    
    myConn.BeginTrans '开始
    '执行语句
    myConn.Execute strDeleteSql
    If Err.Number = 0 Then
        myConn.CommitTrans '---提交事務
        MsgBox "删除成功.", vbExclamation, "提示"
    Else
        myConn.RollbackTransaction
        MsgBox "删除失败!", vbExclamation, "提示"
    End If
    '===事务处理结束====================================================

    Call InitDepartmentListBox
    Call InitCmbDepartment
    
    txtDepartmentName.Text = ""
    optPhoto = True