frmformula.frm

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

      Caption         =   "<"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmFormula"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType
Dim mblnChecked As Boolean
Dim mnodChecked As Node
Dim m_strMenu As String

Public Sub ShowForm(ByVal strMenu As String)
    m_strMenu = strMenu
    Me.Show vbModal
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim itmTemp As ListItem
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    txtName.Enabled = True
    txtDescription.Enabled = True
    
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    
    '清空显示
    txtName.Text = ""
    txtDescription.Text = ""
    txtPrice.Enabled = True
    txtPrice.Text = ""
    
    menuOperation = Add
    
    '清除已选组合
    lvwChecked.ListItems.Clear
    lvwUnchecked.ListItems.Clear
    '添加所有未选组合
    '显示当前套餐未包含的大项
    strSQL = "select DXID,DXMC,DXJG from SET_DX"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do
            Set itmTemp = lvwUnchecked.ListItems.Add(, "W" & rstemp("DXID"), rstemp("DXMC"))
            itmTemp.SubItems(1) = rstemp("DXJG") & ""
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
    End If
    
    EnableCommand
    
    txtName.SetFocus
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdAddAll_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim intTCID As String
    Dim strTCMC As String
    Dim strDXID As String
    Dim strDXMC As String
    Dim itmTemp As ListItem
    Dim i As Integer
    Dim lngIndex As Long
    
    Me.MousePointer = vbHourglass
    
    '是否有选择组合
    If lvwUnchecked.SelectedItem Is Nothing Then
        MsgBox "请选择要添加的组合", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    With lvwUnchecked
        '循环每一个组合
        For i = .ListItems.Count To 1 Step -1
            '添加到目标
            Set itmTemp = lvwChecked.ListItems.Add(, .ListItems(i).Key, .ListItems(i).Text)
            itmTemp.SubItems(1) = .ListItems(i).SubItems(1)
            
            '从源处移除
            lngIndex = .ListItems(i).Index
            .ListItems.Remove lngIndex
        Next i
    End With
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdAddDX_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim intTCID As String
    Dim strTCMC As String
    Dim strDXID As String
    Dim strDXMC As String
    Dim itmTemp As ListItem
    Dim i As Integer
    Dim lngIndex As Long
    Dim blnSelect As Boolean
    
    Me.MousePointer = vbHourglass
    
    '是否有选择组合
    If lvwUnchecked.SelectedItem Is Nothing Then
        MsgBox "请选择要添加的组合", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    With lvwUnchecked
        '循环每一个组合
        For i = .ListItems.Count To 1 Step -1
            '是否已选择
            If .ListItems(i).Selected = True Then
                blnSelect = True
                
                '添加到目标
                Set itmTemp = lvwChecked.ListItems.Add(, .ListItems(i).Key, .ListItems(i).Text)
                itmTemp.SubItems(1) = .ListItems(i).SubItems(1)
                
                '从源处移除
                lngIndex = .ListItems(i).Index
                .ListItems.Remove lngIndex
            End If
        Next i
    End With
    
    If blnSelect = False Then
        MsgBox "请选择要添加的组合", vbInformation, "提示"
    End If
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdCancel_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    '是否有套餐
    If lstFormula.ListCount < 1 Then
        MsgBox "当前没有套餐，无从删除！", vbInformation, "提示"
        Exit Sub
    End If
    
    '是否有选择
    If lstFormula.Text = "" Then
        MsgBox "请单击左侧的列表框选择要删除的套餐！", vbInformation, "提示"
        Exit Sub
    End If
    
    '确认删除
    If MsgBox("该操作不可恢复！" & vbCrLf & "确实要删除套餐“" _
            & lstFormula.Text & "”吗?", _
            vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then Exit Sub
    
    '删除SET_TC中的项
    strSQL = "delete from SET_TC" _
            & " where TCID=" & Val(lstFormula.ItemData(lstFormula.ListIndex))
    Status = Execute(strSQL)
    If ErrTrue(Status) Then
        ErrMsg Status
        Exit Sub
    End If
    
    '删除SET_TCDX中的项
    strSQL = "delete from SET_TCDX" _
            & " where TCID=" & Val(lstFormula.ItemData(lstFormula.ListIndex))
    Status = Execute(strSQL)
    If ErrTrue(Status) Then
        ErrMsg Status
    End If
    
    '删除相应项
    lstFormula.RemoveItem (lstFormula.ListIndex)
    
    '移动焦点
    If lstFormula.ListCount >= 1 Then
        lstFormula.ListIndex = 0
    Else
        lstFormula_Click
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, "加载套餐时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
End Sub

Private Sub cmdDeleteAll_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim intTCID As String
    Dim strTCMC As String
    Dim strDXID As String
    Dim strDXMC As String
    Dim itmTemp As ListItem
    Dim i As Integer
    Dim lngIndex As Long
    
    Me.MousePointer = vbHourglass
    
    '是否有选择组合
    If lvwChecked.SelectedItem Is Nothing Then
        MsgBox "请选择要删除的组合", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    With lvwChecked
        '循环每一个组合
        For i = .ListItems.Count To 1 Step -1
            '添加到目标
            Set itmTemp = lvwUnchecked.ListItems.Add(, .ListItems(i).Key, .ListItems(i).Text)
            itmTemp.SubItems(1) = .ListItems(i).SubItems(1)
            
            '从源处移除
            lngIndex = .ListItems(i).Index
            .ListItems.Remove lngIndex
        Next i
    End With
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDeleteDX_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim intTCID As String
    Dim strTCMC As String
    Dim strDXID As String
    Dim strDXMC As String
    Dim itmTemp As ListItem
    Dim i As Integer
    Dim lngIndex As Long
    Dim blnSelect As Boolean
    
    Me.MousePointer = vbHourglass
    
    '是否有选择组合
    If lvwChecked.SelectedItem Is Nothing Then
        MsgBox "请选择要删除的组合", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    With lvwChecked
        '循环每一个组合
        For i = .ListItems.Count To 1 Step -1
            '是否已选择
            If .ListItems(i).Selected = True Then
                blnSelect = True
                
                '添加到目标
                Set itmTemp = lvwUnchecked.ListItems.Add(, .ListItems(i).Key, .ListItems(i).Text)
                itmTemp.SubItems(1) = .ListItems(i).SubItems(1)
                
                '从源处移除
                lngIndex = .ListItems(i).Index
                .ListItems.Remove lngIndex
            End If
        Next i
    End With
    
    If blnSelect = False Then
        MsgBox "请选择要删除的组合", vbInformation, "提示"
    End If
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModify_Click()
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    txtName.Enabled = True
    txtDescription.Enabled = True
    txtPrice.Enabled = True
    cmdSave.Enabled = True
    
    cmdModify.Enabled = False
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    
    EnableCommand
    
    menuOperation = Modify
    
    txtName.SetFocus
ExitLab:

End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String