frmtjdw.frm

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

    Call DeleteItemFromListView(lvwDWei, lvwDWei.SelectedItem.Index)
    LvwDWei_Click
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModify_Click()
    '是否有选择
    If lvwDWei.SelectedItem Is Nothing Then
        MsgBox "请在左侧的列表里面选择要修改的单位！", vbInformation, "提示"
        Exit Sub
    End If
    
    EnableInput True
    
    cmdAdd.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    
    menuOperation = Modify
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim cmd As ADODB.Command
    Dim rstemp As ADODB.Recordset
    Dim strMaxID As String
    Dim itmTemp As ListItem
    
    Me.MousePointer = vbHourglass
    
    '是否输入单位名称
    If txtTDWMC.Text = "" Then
        MsgBox "请输入单位名称！", vbInformation, "提示"
        txtTDWMC.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入了单位联系人
    If txtTLXR.Text = "" Then
        MsgBox "请输入单位联系人！", vbInformation, "提示"
        txtTLXR.SetFocus
        GoTo ExitLab
    End If
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon

    '查看单位是否已经存在
    If menuOperation = Add Then
        '添加，和修改而名称又被改变的情况，要验证新名称是否已经存在
        strSQL = "select Count(*) from SET_DW" _
                & " where DWMC='" & txtTDWMC.Text & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp(0) > 0 Then
            MsgBox "您输入的单位名称已经存在，请核对后重新输入！", vbInformation, "提示"
            txtTDWMC.SetFocus
            GoTo ExitLab
        End If
    End If
    
    If menuOperation = Modify Then
        If lvwDWei.SelectedItem.Text <> txtTDWMC.Text Then
            '添加，和修改而名称又被改变的情况，要验证新名称是否已经存在
            strSQL = "select Count(*) from SET_DW" _
                    & " where DWMC='" & txtTDWMC.Text & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rstemp(0) > 0 Then
                MsgBox "您输入的单位名称已经存在，请核对后重新输入！", vbInformation, "提示"
                txtTDWMC.SetFocus
                GoTo ExitLab
            End If
        End If
    End If
    
    If menuOperation = Add Then
        '来的是新单位，提取其资料
        '首先获取单位的最大id
        strMaxID = GetMaxID("SET_DW", "DWID", "00001")
        strSQL = "insert into SET_DW(DWID) values('" & strMaxID & "')"
        cmd.CommandText = strSQL
        cmd.Execute
        
        strSQL = "insert into SET_DW_APPEND(DWID) values('" & strMaxID & "')"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        strMaxID = Mid(lvwDWei.SelectedItem.Key, 2)
    End If
    
    '更新单位信息
    strSQL = "update SET_DW set" _
            & " DWMC='" & txtTDWMC.Text & "'" _
            & ",ShortName='" & txtShortName.Text & "'" _
            & ",PYSX='" & txtTPYSX.Text & "'" _
            & ",WBSX='" & txtTWBSX.Text & "'" _
            & ",LXR='" & txtTLXR.Text & "'" _
            & ",LXRBGDH='" & txtTLXRBGDH.Text & "'" _
            & ",LXRYDDH='" & txtTLXRYDDH.Text & "'" _
            & ",LXREMail='" & txtTLXREMail.Text & "'" _
            & ",FZR='" & txtTFZR.Text & "'" _
            & ",FZRBGDH='" & txtTFZRBGDH.Text & "'" _
            & ",FZRYDDH='" & txtTFZRYDDH.Text & "'" _
            & ",LXDZ='" & txtTLXDZ.Text & "'" _
            & ",YZBM='" & txtTYZBM.Text & "'" _
            & ",YWYH='" & txtTYWYH.Text & "'" _
            & ",YHZH='" & txtTYHZH.Text & "'" _
            & ",QYXZ='" & txtTQYXZ.Text & "'" _
            & " where DWID='" & strMaxID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    '如果是添加，直接加到左侧的列表
    If menuOperation = Add Then
        Set itmTemp = lvwDWei.ListItems.Add(, "W" & strMaxID, txtTDWMC.Text)
        Set lvwDWei.SelectedItem = itmTemp
    Else
        If lvwDWei.SelectedItem.Text <> txtTDWMC.Text Then
            lvwDWei.SelectedItem.Text = txtTDWMC.Text
        End If
    End If
    LvwDWei_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 rsDW As ADODB.Recordset
    
    '显示已经存在的单位
    strSQL = "select DWID,DWMC from SET_DW"
    Set rsDW = New ADODB.Recordset
    rsDW.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsDW.RecordCount > 0 Then
        rsDW.MoveFirst
        Do
            lvwDWei.ListItems.Add , "W" & rsDW("DWID"), rsDW("DWMC")
            
            rsDW.MoveNext
        Loop Until rsDW.EOF
        rsDW.Close
    End If
    Set rsDW = Nothing
    
    LvwDWei_Click
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'清除所有显示
Private Sub ClearInput()
    txtTDWMC.Text = ""
    txtShortName.Text = ""
    txtTPYSX.Text = ""
    txtTWBSX.Text = ""
    txtTLXR.Text = ""
    txtTLXRBGDH.Text = ""
    txtTLXRYDDH.Text = ""
    txtTLXREMail.Text = ""
    txtTFZR.Text = ""
    txtTLXDZ.Text = ""
    txtTFZRBGDH.Text = ""
    txtTFZRYDDH.Text = ""
    txtTYZBM.Text = ""
    txtTYWYH.Text = ""
    txtTYHZH.Text = ""
    txtTQYXZ.Text = ""
End Sub

Private Sub LvwDWei_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    EnableInput False
    
    cmdAdd.Enabled = True
    cmdSave.Enabled = False
    
    '如果单位不存在则直接退出
    If lvwDWei.SelectedItem Is Nothing Then
        ClearInput
        cmdModify.Enabled = False
        cmdDelete.Enabled = False
        Exit Sub
    Else
        cmdModify.Enabled = True
        cmdDelete.Enabled = True
    End If
    
    '单位存在的情况，调出历史记录
    strSQL = "select * from SET_DW" _
            & " where DWID='" _
            & Mid(lvwDWei.SelectedItem.Key, 2) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    '填充窗体上的文本框
    txtTDWMC.Text = lvwDWei.SelectedItem.Text
    
    txtShortName.Text = rstemp("ShortName") & ""
    txtTPYSX.Text = rstemp("PYSX") & ""
    txtTWBSX.Text = rstemp("WBSX") & ""
    txtTLXR.Text = rstemp("LXR") & ""
    txtTLXRBGDH.Text = rstemp("LXRBGDH") & ""
    txtTLXRYDDH.Text = rstemp("LXRYDDH") & ""
    txtTLXREMail.Text = rstemp("LXREMail") & ""
    txtTFZR.Text = rstemp("FZR") & ""
    txtTFZRBGDH.Text = rstemp("FZRBGDH") & ""
    txtTFZRYDDH.Text = rstemp("FZRYDDH") & ""
    txtTYZBM.Text = rstemp("YZBM") & ""
    txtTLXDZ.Text = rstemp("LXDZ") & ""
    txtTYWYH.Text = rstemp("YWYH") & ""
    txtTYHZH.Text = rstemp("YHZH") & ""
    txtTQYXZ.Text = rstemp("QYXZ") & ""
    '关闭记录集
    rstemp.Close
    Set rstemp = Nothing
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'启用/禁用输入框
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtTDWMC.Enabled = blnFlag
    txtShortName.Enabled = blnFlag
    txtTLXR.Enabled = blnFlag
    txtTLXRBGDH.Enabled = blnFlag
    txtTLXRYDDH.Enabled = blnFlag
    txtTLXREMail.Enabled = blnFlag
    txtTFZR.Enabled = blnFlag
    txtTFZRBGDH.Enabled = blnFlag
    txtTFZRYDDH.Enabled = blnFlag
    txtTLXDZ.Enabled = blnFlag
    txtTYZBM.Enabled = blnFlag
    txtTYWYH.Enabled = blnFlag
    txtTYHZH.Enabled = blnFlag
    txtTQYXZ.Enabled = blnFlag
End Sub

Private Sub txtTFZR_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTFZRBGDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTFZRYDDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTLXDZ_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTLXR_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTLXRBGDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTLXREMail_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTLXRYDDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTQYXZ_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTYHZH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTYWYH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtTYZBM_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub