frmbbzh.frm

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

    '***********************************************************
    Select Case genuVersion
        Case WLB
            '
        Case ZYB
        
        Case BZB
            If cmbBBZH.ListCount >= 2 Then
                MsgBox "您使用的是标准版，只能设置2套报表组合！", vbInformation, "提示"
                GoTo ExitLab
            End If
        Case PJB
            If cmbBBZH.ListCount >= 1 Then
                MsgBox "您使用的是普及版，只能设置2套报表组合！", vbInformation, "提示"
                GoTo ExitLab
            End If
    End Select
    '***********************************************************
    '***********************************************************
    
    '让用户输入组合名称
    strZHMC = InputBox("请输入您要添加的报表组合的名称（提示：该名称必须唯一）：", "报表组合")
    If strZHMC = "" Then GoTo ExitLab
    
    '检查该名称是否已经存在
    strSQL = "select Count(*) from REPORT_ZH" _
            & " where ZHMC='" & strZHMC & "'"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsReport(0) >= 1 Then
        MsgBox "您输入的报表组合名称已经存在！请核对后重试！", vbInformation, "提示"
        GoTo ExitLab
    End If
    rsReport.Close
    
    '校验通过
    '获取当前最大编号
    strMaxID = GetMaxID("REPORT_ZH", "ZHID", "00001")
    '首先写入数据库
    strSQL = "insert into REPORT_ZH values(" _
            & "'" & strMaxID & "'" _
            & ",'" & strZHMC & "')"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    mstrZHID = strMaxID
    
    '添加到组合框
    cmbBBZH.AddItem strZHMC
    cmbBBZH.ItemData(cmbBBZH.NewIndex) = strMaxID
    cmbBBZH.ListIndex = cmbBBZH.NewIndex
    
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdAddReport_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim strBBID As String
    Dim intSXH As Integer
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    If cmdAddReport.Enabled = False Then GoTo ExitLab
    
    '是否有当前报表组合
    If cmbBBZH.Text = "" Then GoTo ExitLab
    
    '是否有可移动的报表
    If lvwAll.ListItems.Count < 1 Then GoTo ExitLab
    '是否有选择
    If lvwAll.SelectedItem Is Nothing Then GoTo ExitLab
    
    '是否已经存在
    strBBID = lvwAll.SelectedItem.Key
    For i = 1 To lvwReport.ListItems.Count
        If lvwReport.ListItems(i).Key = strBBID Then
            MsgBox "该报表已经存在于当前报表组合之中！", vbInformation, "提示"
            GoTo ExitLab
        End If
    Next
    strBBID = Mid(strBBID, 2) '截掉最前面的符号
    
    '校验完毕
    '首先获取顺序号
    strSQL = "select max(SXH) from REPORT_ZHDT" _
            & " where ZHID='" & mstrZHID & "'"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If IsNull(rsReport(0)) Then
        intSXH = 1
    Else
        intSXH = rsReport(0) + 1
    End If
    
    '写入数据库
    strSQL = "insert into REPORT_ZHDT values(" _
            & "'" & mstrZHID & "'" _
            & ",'" & strBBID & "'" _
            & "," & intSXH & ")"
    GCon.Execute strSQL
    
    '添加到左侧
    lvwReport.ListItems.Add , lvwAll.SelectedItem.Key, lvwAll.SelectedItem.Text
    '删除右侧
    i = lvwAll.SelectedItem.Index
    lvwAll.ListItems.Remove i
    If lvwAll.ListItems.Count > 0 Then
        If i = 1 Then
            Set lvwAll.SelectedItem = lvwAll.ListItems(i)
        Else
            Set lvwAll.SelectedItem = lvwAll.ListItems(i - 1)
        End If
    End If
    
    Set rsReport = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim strNewZHMC As String
    Dim intIndex As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有报表组合
    If cmbBBZH.ListCount < 0 Then GoTo ExitLab
    
    '是否有选择
    If cmbBBZH.Text = "" Then
        MsgBox "请选择您要删除的报表组合！", vbInformation, "提示"
        cmbBBZH.SetFocus
        GoTo ExitLab
    End If
    
    If MsgBox("该操作不可恢复！" & vbCrLf _
            & "您确认要删除报表组合“" & cmbBBZH.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then GoTo ExitLab
            
    '校验通过
    '改写数据库
    strSQL = "delete from REPORT_ZH" _
            & " where ZHID='" & mstrZHID & "'"
    GCon.Execute strSQL
    strSQL = "delete from REPORT_ZHDT" _
            & " where ZHID='" & mstrZHID & "'"
    GCon.Execute strSQL
    
    '删除组合框的显示
    intIndex = cmbBBZH.ListIndex
    cmbBBZH.RemoveItem intIndex
    If cmbBBZH.ListCount > 0 Then
        If intIndex = 0 Then
            cmbBBZH.ListIndex = intIndex
        Else
            cmbBBZH.ListIndex = intIndex - 1
        End If
    Else
        cmbBBZH_Click
    End If
    
    Set rsReport = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDeleteReport_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strBBID As String
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    If cmdDeleteReport.Enabled = False Then GoTo ExitLab
    
    '是否有当前报表组合
    If cmbBBZH.Text = "" Then GoTo ExitLab
    
    '是否有可移动的报表
    If lvwReport.ListItems.Count < 1 Then GoTo ExitLab
    '是否有选择
    If lvwReport.SelectedItem Is Nothing Then GoTo ExitLab
    
    '是否已经存在
    strBBID = lvwReport.SelectedItem.Key
'    For i = 1 To lvwAll.ListItems.Count
'        If lvwAll.ListItems(i).Key = strBBID Then
'            MsgBox "该报表已经存在于当前报表组合之中！", vbInformation, "提示"
'            GoTo ExitLab
'        End If
'    Next
    strBBID = Mid(strBBID, 2) '截掉最前面的符号
    
    '校验完毕
    '写入数据库
    strSQL = "delete from REPORT_ZHDT" _
            & " where ZHID='" & mstrZHID & "'" _
            & " and BBID='" & strBBID & "'"
    GCon.Execute strSQL
    
    '添加到左侧
    lvwAll.ListItems.Add , lvwReport.SelectedItem.Key, lvwReport.SelectedItem.Text
    '删除右侧
    i = lvwReport.SelectedItem.Index
    lvwReport.ListItems.Remove i
    If lvwReport.ListItems.Count > 0 Then
        If i = 1 Then
            Set lvwReport.SelectedItem = lvwReport.ListItems(i)
        Else
            Set lvwReport.SelectedItem = lvwReport.ListItems(i - 1)
        End If
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModify_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim strNewZHMC As String
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有选择
    If cmbBBZH.Text = "" Then GoTo ExitLab
    
    strNewZHMC = InputBox("请输入新的报表组合的名称（提示：该名称必须唯一）：", "报表组合", cmbBBZH.Text)
    If strNewZHMC = "" Then GoTo ExitLab
    
    If strNewZHMC = cmbBBZH.Text Then GoTo ExitLab
    
    '检查是否已经存在
    strSQL = "select Count(*) from REPORT_ZH" _
            & " where ZHMC='" & strNewZHMC & "'"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsReport(0) >= 1 Then
        MsgBox "您输入的报表组合名称已经存在，请核对后重新输入！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '校验通过
    '改写数据库
    strSQL = "update REPORT_ZH set" _
            & " ZHMC='" & strNewZHMC & "'" _
            & " where ZHID='" & mstrZHID & "'"
    GCon.Execute strSQL
    
    '修改组合框的显示
    cmbBBZH.List(cmbBBZH.ListIndex) = strNewZHMC
    
    Set rsReport = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdOK_Click()
    Unload Me
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim i As Integer
    
    Screen.MousePointer = vbArrowHourglass
    
    '获取所有报表组合
    strSQL = "select * from REPORT_ZH"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rsReport.EOF Then
        rsReport.MoveFirst
        Do
            cmbBBZH.AddItem rsReport("ZHMC")
            cmbBBZH.ItemData(cmbBBZH.NewIndex) = rsReport("ZHID")
            
            rsReport.MoveNext
        Loop Until rsReport.EOF
        
        cmbBBZH.ListIndex = 0
        rsReport.Close
    End If
    Set rsReport = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwAll_DblClick()
    cmdAddReport_Click
End Sub

Private Sub lvwAll_DragDrop(Source As Control, X As Single, Y As Single)
    If Source.name = lvwReport.name Then
        cmdDeleteReport_Click
    End If
End Sub

Private Sub lvwAll_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    lvwAll.Drag vbBeginDrag
End Sub

Private Sub lvwReport_DblClick()
    cmdDeleteReport_Click
End Sub

Private Sub lvwReport_DragDrop(Source As Control, X As Single, Y As Single)
    If Source.name = lvwAll.name Then
        cmdAddReport_Click
    End If
End Sub

Private Sub lvwReport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    lvwReport.Drag vbBeginDrag
End Sub