frmmanager.frm

本系统可用于医院和专业体检中心的健康体检管理

'            strJSID = Left(strJSID, Len(strJSID) - 1)
'        End If
'
'        '如果是科室医生
'        If blnHave Then
'            With lstKeShi
'                For i = 0 To .ListCount - 1
'                    If .Selected(i) Then
'                        strKSID = strKSID & LongToString(.ItemData(i), 2) & ","
'                    End If
'                Next i
'            End With
'
'            '是否选了科室
'            If strKSID = "" Then
'                MsgBox "请选择用户 " & strJobNumber & " 管理的科室！", vbInformation, "提示"
'                GoTo ExitLab
'            Else
'                strKSID = Left(strKSID, Len(strKSID) - 1)
'            End If
'        End If
'    End With
    
    '校验时间
    If dtpBirthday.Value > dtpZZSJ.Value Then
        MsgBox "出生日期不能比在职时间晚，请核对后重新输入！", vbInformation, "提示"
        dtpBirthday.SetFocus
        GoTo ExitLab
    End If
    
    '开始事务
    GCon.BeginTrans
    On Error GoTo RollBack
    
    If m_enuOperation = Add Then
        intEmployeeID = CInt(GetAvailableID("RY_Employee", "EmployeeID", True))
        '插入一条空记录
        strSQL = "insert into RY_Employee(EmployeeID,Name,JobNumber) values(" _
                & intEmployeeID _
                & ",'" & strName & "','" & strJobNumber & "'" _
                & ")"

        GCon.Execute strSQL
    Else
        intEmployeeID = CInt(Val(Mid(lvwEmployee.SelectedItem.Key, 2)))
    End If
    
    dtmNow = Now
    '更新其余部分
    strSQL = "update RY_Employee set" _
            & " JobNumber='" & strJobNumber & "'" _
            & ",Name='" & strName & "'" _
            & ",Password='" & txtPassword.Text & "'" _
            & ",Sex='" & IIf(optMale.Value, "男", "女") & "'" _
            & ",Birthday='" & dtpBirthday.Value & "'" _
            & ",ZZSJ='" & dtpZZSJ.Value & "'" _
            & ",JSID='" & strJSID & "'" _
            & ",KSID=" & IIf(strKSID = "", "null", "'" & strKSID & "'") _
            & ",TelphoneHome='" & Trim(txtTelphoneHome.Text) & "'" _
            & ",TelphoneMobile='" & Trim(txtTelphoneMobile.Text) & "'" _
            & ",Address='" & Trim(txtAddress.Text) & "'" _
            & ",Enabled=1" _
            & ",XGSJ='" & dtmNow & "'" _
            & ",ModifyManager=" & gintManagerID
    If m_enuOperation = Add Then
        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
                & ",BuildManager=" & gintManagerID
    End If
    strSQL = strSQL & " where EmployeeID=" & intEmployeeID
    GCon.Execute strSQL
    
    '写入签名
    If imgSign.PICTURE <> 0 Then
        '打开记录集
        strSQL = "select EmployeeID,Sign from RY_Employee" _
                & " where EmployeeID=" & intEmployeeID
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
        
        strTempFile = GetTempPathW & "Sign.jpg"
        If Dir(strTempFile) <> "" Then Kill strTempFile
        Call SavePicture(imgSign.PICTURE, strTempFile)
        If WriteToDB(rsTemp("Sign"), strTempFile) Then rsTemp.Update
        rsTemp.Close
    End If
    
    '提交事务
    GCon.CommitTrans
    On Error GoTo ErrMsg
    
    '添加到左侧的ListView
    With lvwEmployee
        If m_enuOperation = Add Then
            Set itmTemp = .ListItems.Add(, HEADER & CStr(intEmployeeID))
            Set .SelectedItem = itmTemp
        Else
            Set itmTemp = .SelectedItem
        End If
        itmTemp.Text = strJobNumber
        itmTemp.SubItems(1) = strName
    End With
    
    '禁用相应设置
    Call EnableInput(False)
    Call EnableCommand(True)
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Combo1_Click()
    Dim i As Integer
    Dim blnHave As Boolean
    
    
       
            If Combo1.Text = "科室医生" Then
               
               blnHave = True
              
           End If
     
   
    If blnHave Then
        fraKeShi.Visible = True
    Else
        fraKeShi.Visible = False
    End If
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim itmTemp As ListItem
    
    Screen.MousePointer = vbHourglass
    
    '加载所有角色
    strSQL = "select JSID,JSMC from SET_JS_INDEX" _
            & " order by JSMC"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsTemp.EOF Then
        With lstJS
            Do
                .AddItem rsTemp("JSMC")
                .ItemData(.NewIndex) = rsTemp("JSID")
                 Combo1.AddItem rsTemp("JSMC")
                 Combo1.ItemData(Combo1.NewIndex) = rsTemp("JSID")
                rsTemp.MoveNext
            Loop While Not rsTemp.EOF
            rsTemp.Close
            .ListIndex = 0
            Combo1.ListIndex = 0
        End With
    End If
    
    '加载所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ" _
            & " order by SXH"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsTemp.EOF Then
        With lstKeShi
            Do
                .AddItem rsTemp("KSMC")
                .ItemData(.NewIndex) = rsTemp("KSID")
                
                rsTemp.MoveNext
            Loop While Not rsTemp.EOF
            rsTemp.Close
        End With
    End If
    
    '提取所有操作员
    strSQL = "select EmployeeID,JobNumber,Name from RY_Employee" _
            & " where Enabled=1" _
            & " order by JobNumber"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsTemp.EOF Then
        With lvwEmployee
            Do
                Set itmTemp = .ListItems.Add(, HEADER & rsTemp("EmployeeID"), rsTemp("JobNumber") & "")
                itmTemp.SubItems(1) = rsTemp("Name")
                
                rsTemp.MoveNext
            Loop While Not rsTemp.EOF
            rsTemp.Close
            
            Set .SelectedItem = .ListItems(1)
            Call lvwEmployee_Click
        End With
    End If
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lstJS_Click()
    Dim i As Integer
    Dim blnHave As Boolean
    
    With lstJS
        For i = 0 To .ListCount - 1
            If .List(i) = "科室医生" Then
                If .Selected(i) Then blnHave = True
                Exit For
            End If
        Next i
    End With
    
    If blnHave Then
        fraKeShi.Visible = True
    Else
        fraKeShi.Visible = False
    End If
End Sub

Private Sub lvwEmployee_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strValue As String
    Dim intJSID, strKSID
    Dim i As Integer, j As Integer
    Dim blnHave As Boolean
    Dim strTempFile As String
    
    Me.MousePointer = vbArrowHourglass
    
    Call EnableInput(False)
    Call EnableCommand(False)
    If lvwEmployee.SelectedItem Is Nothing Then GoTo ExitLab
    
    strSQL = "select * from RY_Employee" _
            & " where EmployeeID=" & CInt(Val(Mid(lvwEmployee.SelectedItem.Key, 2)))
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    txtJobNumber.Text = rsTemp("JobNumber")
    txtJobNumber.Tag = rsTemp("JobNumber")
    txtName.Text = rsTemp("Name")
    txtPassword.Text = rsTemp("Password")
    If rsTemp("Sex") = "男" Then
        optMale.Value = True
    Else
        optFemale.Value = True
    End If
    dtpBirthday.Value = rsTemp("Birthday")
    dtpZZSJ.Value = rsTemp("ZZSJ")
    '角色
    strValue = rsTemp("JSID")
    intJSID = Split(strValue, ",")
    With lstJS
        For i = 0 To .ListCount - 1
            blnHave = False
            For j = LBound(intJSID) To UBound(intJSID)
                If .ItemData(i) = intJSID(j) Then
                    blnHave = True
                    Exit For
                End If
            Next j
            
            .Selected(i) = blnHave
        Next i
    End With
    
    txtTelphoneHome.Text = rsTemp("TelphoneHome") & ""
    txtTelphoneMobile.Text = rsTemp("TelphoneMobile") & ""
    txtAddress.Text = rsTemp("Address") & ""
    
    '如果是科室医生，需要显示科室
    With lstKeShi
        If rsTemp("KSID") & "" <> "" Then
            strValue = rsTemp("KSID")
            strKSID = Split(strValue, ",")
        
            For i = 0 To .ListCount - 1
                blnHave = False
                For j = LBound(strKSID) To UBound(strKSID)
                    If LongToString(.ItemData(i), 2) = strKSID(j) Then
                        blnHave = True
                        Exit For
                    End If
                Next j
                
                .Selected(i) = blnHave
            Next i
        Else
            For i = 0 To .ListCount - 1
                .Selected(i) = False
            Next i
        End If
    End With
    
    '检查有无签名
    If Not IsNull(rsTemp("Sign")) Then
        strTempFile = GetTempPathW & "Sign.jpg"
        If ReadDB(rsTemp("Sign"), strTempFile) = True Then
            imgSign.PICTURE = LoadPicture(strTempFile)
        Else
            imgSign.PICTURE = LoadPicture() '清除签名
        End If
    Else
        imgSign.PICTURE = LoadPicture() '清除签名
    End If
    
    rsTemp.Close
    Set rsTemp = Nothing
    Call EnableCommand(True, False)
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用/禁用操作按钮
Private Sub EnableCommand(ByVal blnFlag As Boolean, _
        Optional ByVal blnEdit As Boolean = False)
    cmdAdd.Enabled = blnFlag
    cmdModify.Enabled = blnFlag
    cmdDelete.Enabled = blnFlag
    If blnEdit Then
        cmdSave.Enabled = True
    Else
        cmdSave.Enabled = False
    End If
End Sub

'清空输入
Private Sub ClearInput()
    Dim i As Integer
    
    txtJobNumber.Text = ""
    txtJobNumber.Tag = ""
    txtName.Text = ""
    txtPassword.Text = ""
    For i = 0 To lstJS.ListCount - 1
        lstJS.Selected(i) = False
    Next i
    txtTelphoneHome.Text = ""
    txtTelphoneMobile.Text = ""
    txtAddress.Text = ""
    Call cmdDeleteSign_Click
End Sub

'启用/禁用输入
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtJobNumber.Enabled = blnFlag
    txtName.Enabled = blnFlag
    txtPassword.Enabled = blnFlag
    lstJS.Enabled = blnFlag
    txtTelphoneHome.Enabled = blnFlag
    txtTelphoneMobile.Enabled = blnFlag
    txtAddress.Enabled = blnFlag
    cmdBrowser.Enabled = blnFlag
    cmdDeleteSign.Enabled = blnFlag
End Sub