frmhcgl.frm

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

    EnableInput True
    
    '获取当前的唯一编号
    txtHCID.Text = GetMaxID
    
    EnableCommand False
    menuOperation = Add
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim itmHC As ListItem
    Dim intIndex As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有记录
    If lvwTJHC.ListItems.Count < 1 Then
        lvwTJHC_Click
        GoTo ExitLab
    End If
    
    '是否有选择
    If lvwTJHC.SelectedItem Is Nothing Then
        lvwTJHC_Click
        GoTo ExitLab
    End If
    
    '确认删除
    If MsgBox("该操作不可恢复！" & vbCrLf & "您确实要删除耗材“" _
            & txtHCMC.Text & "”及其所有相关数据吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then GoTo ExitLab
    '删除表TJHC_Index里面的相关数据
    strSQL = "delete from TJHC_Index" _
            & " where HCID=" & Val(Mid(lvwTJHC.SelectedItem.Key, 2))
    GCon.Execute strSQL
    '删除表TJHC_HCXM里面的相关数据
    strSQL = "delete from TJHC_HCXM" _
            & " where HCID=" & Val(Mid(lvwTJHC.SelectedItem.Key, 2))
    GCon.Execute strSQL
    
    intIndex = lvwTJHC.SelectedItem.Index
    '删除网格里面的数据
    lvwTJHC.ListItems.Remove intIndex
    
    '移动焦点
    If lvwTJHC.ListItems.Count >= 1 Then
        If intIndex = 1 Then
            Set lvwTJHC.SelectedItem = lvwTJHC.ListItems(intIndex)
        Else
            Set lvwTJHC.SelectedItem = lvwTJHC.ListItems(intIndex - 1)
        End If
    Else
        ClearInput
    End If
    
    lvwTJHC_Click

    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdModify_Click()
    If lvwTJHC.ListItems.Count < 1 Then Exit Sub
    If lvwTJHC.SelectedItem Is Nothing Then Exit Sub
    
    EnableInput True
    
    EnableCommand False
    menuOperation = Modify
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim itmHC As ListItem
    Dim intSex As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有id
    If Val(txtHCID.Text) < 1 Then
        MsgBox "请单击“添加”按钮以生成唯一的编号！", vbInformation, "提示"
'        txtHCID.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入了耗材名称
    txtHCMC.Text = Trim(txtHCMC.Text)
    If txtHCMC.Text = "" Then
        MsgBox "请输入耗材名称！", vbInformation, "提示"
        txtHCMC.SetFocus
        GoTo ExitLab
    End If
    
    txtHCYL.Text = Int(Val(txtHCYL.Text))

    txtHCJG.Text = Val(txtHCJG.Text)
    
    '是否选择了性别
    If (optTY.Value = False) And (optMale.Value = False) And (optFemale.Value = False) Then
        MsgBox "请设置耗材“" & txtHCMC.Text & "”的使用性别！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '设置性别
    If optTY.Value Then
        intSex = 0
    ElseIf optMale Then
        intSex = 1
    Else
        intSex = 2
    End If
    
    If menuOperation = Add Then
        '如果是添加
        '首先重新获取ID号，以防其他客户端占用id号
        txtHCID.Text = GetMaxID
        '其次插入一条空记录
        strSQL = "insert into TJHC_Index(HCID) values(" & Val(txtHCID.Text) & ")"
        GCon.Execute strSQL
    End If
    
    '开始更新
    strSQL = "update TJHC_Index set" _
            & " HCMC='" & txtHCMC.Text & "'" _
            & ",HCSM='" & txtHCSM.Text & "'" _
            & ",MRYL=" & Int(Val(txtHCYL.Text)) _
            & ",HCDW='" & TxtHCDW.Text & "'" _
            & ",Price=" & CCur(txtHCJG.Text) _
            & ",NNTY=" & intSex _
            & " where HCID=" & Val(txtHCID.Text)
    GCon.Execute strSQL
    
    '添加到ListView
    If menuOperation = Add Then
        Set itmHC = Me.lvwTJHC.ListItems.Add(, "W" & txtHCID.Text, txtHCMC.Text)
    Else
        Set itmHC = Me.lvwTJHC.SelectedItem
        itmHC.Text = txtHCMC.Text
    End If
    itmHC.SubItems(1) = txtHCSM.Text
    itmHC.SubItems(2) = Int(Val(txtHCYL.Text))
    itmHC.SubItems(3) = TxtHCDW.Text
    itmHC.SubItems(4) = CCur(txtHCJG.Text)
    If optTY.Value Then
        itmHC.SubItems(5) = optTY.Caption
    ElseIf optMale.Value Then
        itmHC.SubItems(5) = optMale.Caption
    Else
        itmHC.SubItems(5) = optFemale.Caption
    End If
    
    '添加时把焦点移到刚添加的记录上
    If menuOperation = Add Then
        Set lvwTJHC.SelectedItem = itmHC
    End If
    
    lvwTJHC_Click
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsHC As ADODB.Recordset '体检耗材
    Dim itmHC As ListItem
    
    Screen.MousePointer = vbArrowHourglass
    strSQL = "select HCID,HCMC,HCSM,MRYL,HCDW,Price" _
            & ",case NNTY when 0 then '通用' when 1 then '男' when 2 then '女' end as NNTY" _
            & " from TJHC_Index" _
            & " order by HCID"
    Set rsHC = New ADODB.Recordset
    rsHC.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHC.RecordCount > 0 Then
        rsHC.MoveFirst
        With Me.lvwTJHC
            Do
                Set itmHC = .ListItems.Add(, "W" & rsHC("HCID"), rsHC("HCMC"))
                itmHC.SubItems(1) = rsHC("HCSM")
                itmHC.SubItems(2) = rsHC("MRYL")
                itmHC.SubItems(3) = rsHC("HCDW")
                itmHC.SubItems(4) = rsHC("Price")
                itmHC.SubItems(5) = rsHC("NNTY")
                rsHC.MoveNext
            Loop Until rsHC.EOF
        End With
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'启用/禁用输入框
Private Sub EnableInput(blnFlag As Boolean)
    txtHCMC.Enabled = blnFlag
    txtHCSM.Enabled = blnFlag
    txtHCYL.Enabled = blnFlag
    TxtHCDW.Enabled = blnFlag
    txtHCJG.Enabled = blnFlag
    fraSex.Enabled = blnFlag
End Sub

'清空输入框
Private Sub ClearInput()
    txtHCID.Text = ""
    txtHCMC.Text = ""
    txtHCSM.Text = ""
    txtHCYL.Text = ""
    TxtHCDW.Text = ""
    txtHCJG.Text = ""
End Sub

'启用/禁用命令按钮
Private Sub EnableCommand(ByVal blnFlag As Boolean)
    cmdAdd.Enabled = blnFlag
    cmdDelete.Enabled = blnFlag
    cmdModify.Enabled = blnFlag
    cmdSave.Enabled = Not blnFlag
End Sub

'获取当前最大的编号
Private Function GetMaxID() As Integer
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp  As New ADODB.Recordset
    Dim intID As Integer
    Dim i, j As Integer
    Dim intPrevious As Integer
    Dim intNext As Integer
    
    strSQL = "SELECT HCID FROM TJHC_Index" _
           & " ORDER BY HCID"
    rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
    If rstemp.RecordCount = 0 Then  '如果尚未添加耗材,则返回1
        intID = 1
    Else   '否则
        rstemp.MoveFirst
        
        intPrevious = 0
        Do While Not rstemp.EOF
            intNext = rstemp(0)
            If intNext > intPrevious + 1 Then
                intID = intPrevious + 1
                Exit Do
            End If
            
            intPrevious = intNext
            rstemp.MoveNext
        Loop
        
        '检查intID是否有值
        If intID < 1 Then
            rstemp.MoveLast
            intID = rstemp(0) + 1
        End If
        rstemp.Close
    End If
    Set rstemp = Nothing
    GetMaxID = intID
    
    GoTo ExitLab

ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Function

Private Sub lvwTJHC_Click()
    EnableInput False
    cmdAdd.Enabled = True
    cmdSave.Enabled = False
    
    '是否存在记录
    If lvwTJHC.ListItems.Count < 1 Then
        ClearInput
        cmdDelete.Enabled = False
        cmdModify.Enabled = False
        
        Exit Sub
    End If
    
    '是否有选择
    If lvwTJHC.SelectedItem Is Nothing Then
        ClearInput
        cmdDelete.Enabled = False
        cmdModify.Enabled = False
        
        Exit Sub
    End If
    
    '说明有记录并已选择
    cmdDelete.Enabled = True
    cmdModify.Enabled = True
    
    With Me.lvwTJHC.SelectedItem
        txtHCID.Text = Mid(.Key, 2)
        txtHCMC.Text = .Text
        txtHCSM.Text = .SubItems(1)
        txtHCYL.Text = .SubItems(2)
        TxtHCDW.Text = .SubItems(3)
        txtHCJG.Text = .SubItems(4)
        
        If .SubItems(5) = "通用" Then
            optTY.Value = True
        ElseIf .SubItems(5) = "男" Then
            optMale.Value = True
        Else
            optFemale.Value = True
        End If
    End With
End Sub

Private Sub lvwTJHC_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If mintlvPXFC = 1 Then
         mintlvPXFC = 0
         lvwTJHC.SortOrder = lvwAscending
    Else
        mintlvPXFC = 1
        lvwTJHC.SortOrder = lvwDescending
    End If
    '单击 ColumnHeader 对象时，将根据
    '那一列的子项目把 ListView 控件排序。
    '设置 SortKey 为 ColumnHeader 的索引值减 1
    lvwTJHC.SortKey = ColumnHeader.Index - 1
    '设置 Sorted 为 True 以将列表排序。
    lvwTJHC.Sorted = True

End Sub

Private Sub lvwTJHC_DblClick()
    If cmdModify.Enabled = True Then
        cmdModify_Click
    End If
End Sub

Private Sub lvwTJHC_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyUp, vbKeyDown
            lvwTJHC_Click
        Case Else
            '
    End Select
End Sub