frmdictionary.frm

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

        Call DeleteItemFromListView(lvwSJMB, lvwSJMB.SelectedItem.Index)
        lvwSJMB_Click
    End If
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDownDic_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim intCurrIndex As Integer
    Dim strCurrDMID As String
    Dim strNextDMID As String
    
    Me.MousePointer = vbArrowHourglass
    
    With lvwTemplates
        If .ListItems.Count <= 1 Then GoTo ExitLab
        intCurrIndex = .SelectedItem.Index
        If intCurrIndex = .ListItems.Count Then GoTo ExitLab
        
        intCurrIndex = intCurrIndex + 1
        
        strNextDMID = Mid(.ListItems(.SelectedItem.Index + 1).Key, 2)
        strCurrDMID = Mid(.SelectedItem.Key, 2)
        Call MoveLocation("DM_Dictionary", "SXH", "DMID", strCurrDMID, strNextDMID, True)
        
        tvwXMu_NodeClick tvwXMu.SelectedItem
        
        If .ListItems.Count > intCurrIndex Then
            Set .SelectedItem = .ListItems(intCurrIndex)
        End If
    End With
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
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
    '验证完毕
    
    Call EnableCommand(False, True)
    m_enuOperation = Modify
    txtTemplate.Enabled = True
    If m_blnDictionary Then
        txtTemplate.Text = lvwTemplates.SelectedItem.Text
        cmbType.ListIndex = FindItemInCombox(cmbType.hWnd, lvwTemplates.SelectedItem.SubItems(1))
        cmbType.Enabled = True
    Else
        txtTemplate.Text = lvwSJMB.SelectedItem.Text
    End If
    
    txtTemplate.SetFocus
ExitLab:

End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strKey As String
    Dim strContents As String
    Dim blnCheck As Boolean
    Dim strTable As String
    Dim strDMID As String
    Dim intSXH As Integer
    Dim itmTemp As ListItem
    Dim intType As Integer
    
    Me.MousePointer = vbHourglass
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    
    '是否有输入
    strContents = Trim(txtTemplate.Text)
    txtTemplate.Text = strContents
    If Len(strContents) = 0 Then
        MsgBox "请输入字典或模板数据！", vbInformation, "提示"
        txtTemplate.SetFocus
        GoTo ExitLab
    End If
    
    '是否需要检查重复
    If m_enuOperation = Add Then
        blnCheck = True
    Else
        If m_blnDictionary Then
            If strContents <> lvwTemplates.SelectedItem.Text Then blnCheck = True
        Else
            If strContents <> lvwSJMB.SelectedItem.Text Then blnCheck = True
        End If
    End If
    
    strTable = IIf(m_blnDictionary, "DM_Dictionary", "DM_Model")
    '检查是否重复
    If blnCheck Then
        strSQL = "select Count(*) from " & strTable _
                & " where XMID='" & strKey & "'" _
                & " and DMValue='" & strContents & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If rsTemp(0) > 0 Then
            MsgBox "您输入的字典或模板已经存在，请核对后重新输入！", vbInformation, "提示"
            txtTemplate.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
    '类别
    If cmbType.ListIndex < 0 Then
        intType = 0
    Else
        intType = cmbType.ItemData(cmbType.ListIndex)
    End If
    
    GCon.BeginTrans
    On Error GoTo RollBack
    '准备写入数据库
    If m_enuOperation = Modify Then
        '获取旧的ID号
        If m_blnDictionary Then
            strDMID = Mid(lvwTemplates.SelectedItem.Key, 2)
        Else
            strDMID = Mid(lvwSJMB.SelectedItem.Key, 2)
        End If
    Else
        '获取新的ID
        strDMID = GetMaxID(strTable, "DMID", "00001", True)
        
        '获取当前最大的可用顺序号
        strSQL = "select top 1 SXH from SET_SXH" _
                & " where SXH not in(" _
                    & "select SXH from " & strTable _
                    & " where XMID='" & strKey & "'" _
                & ")"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsTemp.EOF Then
            intSXH = rsTemp(0)
            rsTemp.Close
        End If
    End If
    
    '更新其余字段
    strSQL = "update " & strTable & " set" _
            & " XMID='" & strKey & "'" _
            & ",DMValue='" & strContents & "'"
    If m_blnDictionary Then strSQL = strSQL & ",zdtype=" & intType
    If m_enuOperation = Add Then
        strSQL = strSQL & ",JLSJ='" & Now & "'" _
                & ",BuildManager=" & gintManagerID _
                & ",SXH=" & intSXH
    Else
        strSQL = strSQL & ",XGSJ='" & Now & "'" _
                & ",ModifyManager=" & gintManagerID
    End If
    strSQL = strSQL & " where DMID='" & strDMID & "'"
    GCon.Execute strSQL
    '提交事务
    GCon.CommitTrans
    On Error GoTo ErrMsg
    
    If m_enuOperation = Add Then
        '添加到ListView中
        If m_blnDictionary Then
            Set itmTemp = lvwTemplates.ListItems.Add(, HEADER & strDMID, strContents)
            itmTemp.SubItems(1) = cmbType.Text
            Set lvwTemplates.SelectedItem = itmTemp
        Else
            Set itmTemp = lvwSJMB.ListItems.Add(, HEADER & strDMID, strContents)
            Set lvwSJMB.SelectedItem = itmTemp
        End If
    Else
        If m_blnDictionary Then
            lvwTemplates.SelectedItem.Text = strContents
            lvwTemplates.SelectedItem.SubItems(1) = cmbType.Text
        Else
            lvwSJMB.SelectedItem.Text = strContents
        End If
    End If
    
    '清空文本框
    txtTemplate.Text = ""
    '调用各自的单击事件
    If m_blnDictionary Then
        lvwTemplates_Click
    Else
        lvwSJMB_Click
    End If
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdUpDic_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim intCurrIndex As Integer
    Dim strCurrDMID As String
    Dim strPrevDMID As String
    
    Me.MousePointer = vbArrowHourglass
    
    With lvwTemplates
        If .ListItems.Count <= 1 Then GoTo ExitLab
        intCurrIndex = .SelectedItem.Index
        If intCurrIndex = 1 Then GoTo ExitLab
        
        intCurrIndex = intCurrIndex - 1
        
        strPrevDMID = Mid(.ListItems(.SelectedItem.Index - 1).Key, 2)
        strCurrDMID = Mid(.SelectedItem.Key, 2)
        Call MoveLocation("DM_Dictionary", "SXH", "DMID", strCurrDMID, strPrevDMID, False)
        
        tvwXMu_NodeClick tvwXMu.SelectedItem
        
        If .ListItems.Count > intCurrIndex Then
            Set .SelectedItem = .ListItems(intCurrIndex)
        End If
    End With
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdUpModel_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim intCurrIndex As Integer
    Dim strCurrDMID As String
    Dim strPrevDMID As String
    
    Me.MousePointer = vbArrowHourglass
    
    With lvwSJMB
        If .ListItems.Count <= 1 Then GoTo ExitLab
        intCurrIndex = .SelectedItem.Index
        If intCurrIndex = 1 Then GoTo ExitLab
        
        intCurrIndex = intCurrIndex - 1
        strPrevDMID = Mid(.ListItems(.SelectedItem.Index - 1).Key, 2)
        strCurrDMID = Mid(.SelectedItem.Key, 2)
        Call MoveLocation("DM_Model", "SXH", "DMID", strCurrDMID, strPrevDMID, False)
        
        tvwXMu_NodeClick tvwXMu.SelectedItem
        
        If .ListItems.Count > intCurrIndex Then
            Set .SelectedItem = .ListItems(intCurrIndex)
        End If
    End With
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDownModel_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim intCurrIndex As Integer
    Dim strCurrDMID As String
    Dim strNextDMID As String
    
    Me.MousePointer = vbArrowHourglass
    
    With lvwSJMB
        If .ListItems.Count <= 1 Then GoTo ExitLab
        intCurrIndex = .SelectedItem.Index
        If intCurrIndex = .ListItems.Count Then GoTo ExitLab
        
        intCurrIndex = intCurrIndex + 1
        
        strNextDMID = Mid(.ListItems(.SelectedItem.Index + 1).Key, 2)
        strCurrDMID = Mid(.SelectedItem.Key, 2)
        Call MoveLocation("DM_Model", "SXH", "DMID", strCurrDMID, strNextDMID, True)
        
        tvwXMu_NodeClick tvwXMu.SelectedItem
        
        If .ListItems.Count > intCurrIndex Then
            Set .SelectedItem = .ListItems(intCurrIndex)
        End If
    End With
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    Screen.MousePointer = vbHourglass
    
    '添加类别
    With cmbType
        .AddItem ""
        .ItemData(.NewIndex) = 0
        .AddItem "部位"
        .ItemData(.NewIndex) = 1
        .AddItem "性质"
        .ItemData(.NewIndex) = 2
        .AddItem "程度"
        .ItemData(.NewIndex) = 3
        .AddItem "大小"
        .ItemData(.NewIndex) = 4
        .ListIndex = 0
    End With
    
    Call LoadKeShiAndXiangMu(tvwXMu)
    
    Call tvwXMu_NodeClick(tvwXMu.SelectedItem)
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwSJMB_Click()
    m_blnDictionary = False
    Call ManipulateCommand(IIf(lvwSJMB.SelectedItem Is Nothing, False, True))
End Sub

Private Sub lvwSJMB_DblClick()
    If cmdModify.Enabled Then cmdModify_Click
End Sub

Private Sub lvwSJMB_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then Call lvwSJMB_Click
End Sub

Private Sub lvwTemplates_Click()
    m_blnDictionary = True
    Call ManipulateCommand(IIf(lvwTemplates.SelectedItem Is Nothing, False, True))
End Sub

Private Sub lvwTemplates_DblClick()
    If cmdModify.Enabled Then cmdModify_Click
End Sub

Private Sub lvwTemplates_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then Call lvwTemplates_Click
End Sub

Private Sub tvwXMu_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strKey As String
    Dim itmTemp As ListItem
    
    Me.MousePointer = vbArrowHourglass
    
    '清除字典和模板
    lvwTemplates.ListItems.Clear
    lvwSJMB.ListItems.Clear
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    If Len(strKey) > 0 Then
        '点击了小项
        '显示数据字典
        strSQL = "select DMID,DMValue,case zdtype when 0 then '' when 1 then '部位' when 2 then '性质' when 3 then '程度' when 4 then '大小' end as Type from DM_Dictionary" _
                & " where XMID='" & strKey & "'" _
                & " order by SXH"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsTemp.EOF Then
            Do
                Set itmTemp = lvwTemplates.ListItems.Add(, HEADER & rsTemp("DMID"), rsTemp("DMValue"))
                itmTemp.SubItems(1) = rsTemp("Type") & ""
                
                rsTemp.MoveNext
            Loop While Not rsTemp.EOF
            rsTemp.Close
        End If
        
        '显示数据模板
        strSQL = "select DMID,DMValue from DM_Model" _
                & " where XMID='" & strKey & "'" _
                & " order by SXH"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsTemp.EOF Then
            Do
                lvwSJMB.ListItems.Add , HEADER & rsTemp("DMID"), rsTemp("DMValue")
                
                rsTemp.MoveNext
            Loop While Not rsTemp.EOF
            rsTemp.Close
        End If
    End If
    lvwTemplates_Click
    
    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
    cmdAddToModel.Enabled = blnFlag
    cmdModify.Enabled = blnFlag
    If blnEdit Then
        cmdSave.Enabled = True
    Else
        cmdSave.Enabled = False
    End If
    cmdDelete.Enabled = blnFlag
End Sub

'根据选择控制按钮区
Private Sub ManipulateCommand(ByVal blnSelected As Boolean)
    If blnSelected Then
        Call EnableCommand(True)
    Else
        Call EnableCommand(False)
        If Len(tvwXMu.SelectedItem.Key) > 1 Then
            cmdAdd.Enabled = True
            cmdAddToModel.Enabled = True
        End If
    End If
    
    txtTemplate.Enabled = False
    cmbType.Enabled = False
End Sub

Private Sub XPCommandButton1_Click()
    Call ExportDictionary(Me.CommonDialog1)
End Sub