frmkssz.frm

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

  Else
    Unload FrmKSSZ
    Set FrmKSSZ = Nothing
  End If
  
End Sub

Private Sub cmdSave_Click()
  If Status = "READ" Then
    GoTo 100
  End If
  If Status = "CHANGE" Then
    rsKS.Open "SELECT * FROM set_KSSZ WHERE KSMC=" & "'" & TreeView1.SelectedItem.Text & "'", GCon, adOpenDynamic, adLockOptimistic
  End If
  If TextKSMC.Text = "" Then
    MsgBox "请输入科室名称", vbInformation, "提示"
    GoTo 100
  Else
    rsKS.Fields("KSMC") = TextKSMC.Text
  End If
  If TextKSPYSX.Text = "" Then
    MsgBox "请输入科室的拼音缩写", vbInformation, "提示"
    GoTo 100
  Else
    rsKS.Fields("KSPYSX") = TextKSPYSX.Text
  End If
  If TextKSPYSX.Text = "" Then
    rsKS.Fields("KSWBSX") = ""
  Else
    rsKS.Fields("KSWBSX") = TextKSWBSX.Text
  End If
  
  '加入顺序号
  rsKS("SXH") = cmbKSSXH.Text
  
  If TextKSSM.Text = "" Then
    rsKS.Fields("KSSM") = ""
  Else
    rsKS.Fields("KSSM") = TextKSSM.Text
  End If

  rsKS.Fields("KSID") = TextKSID.Text
  rsKS.Update
  rsKS.Close
  rsKS.Open "select * from set_KSSZ", GCon, adOpenDynamic, adLockOptimistic
  rsKS.Find "KSID=" & "'" & TextKSID.Text & "'"
  rsKS.Close
  cmdDel.Enabled = True
  cmdChange.Enabled = True
  cmdAdd.Enabled = True
  
  cmdSave.Enabled = False
  CmdOK.Enabled = False
  
  SetAllInput False
  Status = "READ"
  
  KSCount = 1
  DrawNode
  
  MsgBox "保存成功！", vbInformation, "提示"
  
  
100
End Sub

'计算新添加科室的科室ID
Private Function GetKSID() As String
'  Dim tmp1 As Integer
'  Dim tmpKSID As String
'  Dim RStmp As New ADODB.Recordset
'
'  KSCount = 0
'
'  '取得科室数目
'  RStmp.Open "SELECT * FROM set_KSSZ", GCon, adOpenDynamic, adLockOptimistic
'  Do While Not RStmp.EOF
'    KSCount = KSCount + 1
'    RStmp.MoveNext
'  Loop
'  '计算科室ID号,科室ID用两位字符（从"00"到"99")来表示
'
'  If KSCount = 0 Then
'    tmpKSID = "00"
'    RStmp.Close
'  Else
'    tmp1 = 0
'    '找出最大的科室ID号
'    RStmp.MoveFirst
'    Do While Not RStmp.EOF
'      If CInt(RStmp.Fields("KSID")) > tmp1 Then
'        tmp1 = CInt(RStmp.Fields("KSID"))
'      End If
'      RStmp.MoveNext
'    Loop
'
'    If tmp1 < 9 Then
'      tmpKSID = "0" & CStr(tmp1 + 1)
'    ElseIf (tmp1 >= 9) And (tmp1 < 99) Then
'      tmpKSID = CStr(tmp1 + 1)
'    Else
'      MsgBox "科室设置过多,请删除一些", vbInformation, "提示"
'    End If
'    RStmp.Close
'  End If
'
'  Set RStmp = Nothing
'
'  GetKSID = tmpKSID

On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp  As New ADODB.Recordset
    Dim intID As Integer
    Dim blIDExist(1 To 99) As Boolean
    Dim i, j As Integer


    
'**********获取第一个空余的KSID号(20040314加)*****************
   For i = 1 To 99
     blIDExist(i) = False
   Next i

    strSQL = "SELECT * FROM SET_KSSZ "
    rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
    If rsTemp.RecordCount = 0 Then  '如果当前无科室,则返回"01"
        GetKSID = LongToString(1, 2)
        GoTo ExitLab
    Else   '否则
        For j = 1 To 99
            rsTemp.MoveFirst
            For i = 1 To rsTemp.RecordCount
                If rsTemp("KSID") = LongToString(j, 2) Then
                    blIDExist(j) = True
                    Exit For
                End If
                rsTemp.MoveNext
            Next i
        Next j
        '查找第一个未用的ID号
        For i = 1 To 99
          If blIDExist(i) = False Then
            intID = i
            Exit For
          End If
        Next i
        GetKSID = LongToString(intID, 2)
        GoTo ExitLab
    End If
'**********获取第一个空余的DXID号(20040311晚加)完*****************

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

End Function

Private Sub ClearAllInput()
  TextKSID.Text = ""
  TextKSMC.Text = ""
  TextKSSM.Text = ""
  TextKSPYSX.Text = ""
  TextKSWBSX.Text = ""

End Sub

Private Sub CmdChange_Click()
  Status = "CHANGE"
  SetAllInput True
  
  cmdAdd.Enabled = False
  cmdDel.Enabled = False
  cmdChange.Enabled = False
  cmdSave.Enabled = True
  CmdOK.Enabled = True
End Sub

Private Sub SetAllInput(ByVal Stat As Boolean)
  TextKSMC.Enabled = Stat
  TextKSWBSX.Enabled = Stat
  TextKSPYSX.Enabled = Stat
  cmbKSSXH.Enabled = Stat
  TextKSSM.Enabled = Stat
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub Form_Load()
      Dim rootNode As Node
      Dim KSCount As Integer
      
      Status = "READ"    '初始科室信息是处于查询状态
      TotalKS = "TotalKS"
      SetAllInput False
      
      KSCount = 1
      FrmKSSZ.Left = 600
      FrmKSSZ.Top = 400
      FrmKSSZ.Width = fMainForm.Width * 0.6
      FrmKSSZ.Height = fMainForm.Height * 0.7
      Form_Resize
    
      TreeView1.LineStyle = tvwTreeLines '在兄弟节点和父节点之间显示线
      'TreeView1.ImageList = ImageList1 '链接图像列
      TreeView1.Style = tvwTreelinesPlusMinusPictureText   '树状外观包含全部元素
      TreeView1.LabelEdit = tvwManual
      Set rootNode = TreeView1.Nodes.Add(, , TotalKS, "全部科室")
    
      '向TreeView1中添加科室节点
      DrawNode
End Sub

Private Sub DrawNode()
  Dim i As Integer
  Dim KSNode, rootNode As Node
  If TreeView1.Nodes.Count > 1 Then
    TreeView1.Nodes.Clear
    Set rootNode = TreeView1.Nodes.Add(, , TotalKS, "全部科室")
    Set TreeView1.SelectedItem = rootNode
  End If
  rsKS.Open "select * from SET_KSSZ order by SXH", GCon, adOpenDynamic, adLockOptimistic
  Do While Not rsKS.EOF
    Set KSNode = TreeView1.Nodes.Add(TotalKS, tvwChild, "KS" & KSCount, rsKS.Fields("KSMC"))
    KSNode.Text = rsKS.Fields("KSMC")
    rsKS.MoveNext
    KSCount = KSCount + 1
  Loop
  For i = 1 To TreeView1.Nodes.Count
    '展开全部节点。
    TreeView1.Nodes(i).Expanded = True
  Next i
  rsKS.Close
  
  cmdAdd.Enabled = True
  cmdDel.Enabled = False
  cmdChange.Enabled = False
  cmdSave.Enabled = False
  CmdOK.Enabled = False
End Sub

Private Sub Form_Resize()
  TreeView1.Left = 100
  TreeView1.Top = 100
  TreeView1.Width = FrmKSSZ.Width * 0.3
  TreeView1.Height = FrmKSSZ.Height * 0.92

  Frame1.Left = TreeView1.Left + TreeView1.Width + 100
  Frame1.Top = TreeView1.Top
  Frame1.Height = FrmKSSZ.Height * 0.65
  Frame1.Width = FrmKSSZ.Width * 0.65

  Frame2.Left = TreeView1.Left + TreeView1.Width + 100
  Frame2.Top = Frame1.Top + Frame1.Height + 100
  Frame2.Height = TreeView1.Height - 100 - Frame1.Height
  Frame2.Width = FrmKSSZ.Width * 0.65



End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FrmKSSZ = Nothing
End Sub

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

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

Private Sub TextKSMC_LostFocus()
    TextKSPYSX.Text = GetPYJM(TextKSMC.Text)
End Sub

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

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

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

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim rsSXH As ADODB.Recordset
    Dim intSXH As Integer
    
    Me.MousePointer = 11
    strSQL = ""
    
    SetAllInput False
    
    cmdSave.Enabled = False
    CmdOK.Enabled = False
    cmdAdd.Enabled = True
    
    If TreeView1.SelectedItem.Index <> 1 Then '检查是否有子节点,0为无
        If rsKS.State = adStateOpen Then
            Set rsKS = Nothing
            Set rsKS = New ADODB.Recordset
        End If
        rsKS.Open "SELECT * FROM set_KSSZ WHERE KSMC=" & "'" & TreeView1.SelectedItem.Text & "'", GCon, adOpenStatic, adLockReadOnly
        TextKSID.Text = rsKS.Fields("KSID")
        TextKSID.Enabled = False
        TextKSMC.Text = rsKS.Fields("KSMC")
        If rsKS.Fields("KSPYSX") <> "" Then
            TextKSPYSX.Text = rsKS.Fields("KSPYSX")
        Else
            TextKSPYSX.Text = ""
        End If
        If rsKS.Fields("KSWBSX") <> "" Then
            TextKSWBSX.Text = rsKS.Fields("KSWBSX")
        Else
            TextKSWBSX.Text = ""
        End If
        
        '此处加入查询顺序号的语句
        strSQL = "select distinct SXH from SET_SXH" _
                & " where SXH not in (" _
                & "select SXH from SET_KSSZ" _
                & " where KSID<>'" & rsKS("KSID") & "')"
        intSXH = rsKS("SXH")
        
        If rsKS.Fields("KSSM") <> "" Then
            TextKSSM.Text = rsKS.Fields("KSSM")
        Else
            TextKSSM.Text = ""
        End If
    
        rsKS.Close
'        MsgBox TreeView1.SelectedItem.Index
        cmdDel.Enabled = True
        cmdChange.Enabled = True
    Else
        cmdDel.Enabled = False
        cmdChange.Enabled = False
    End If
    
     '获取顺序号
    If strSQL <> "" Then
        '打开记录集
        Set rsSXH = New ADODB.Recordset
        rsSXH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        '清空可能存在的显示
        cmbKSSXH.Clear
        For i = 1 To rsSXH.RecordCount
            cmbKSSXH.AddItem rsSXH("SXH")
            If rsSXH("SXH") = intSXH Then
                cmbKSSXH.ListIndex = cmbKSSXH.NewIndex
            End If
            
            rsSXH.MoveNext
        Next
        
        rsSXH.Close
        Set rsSXH = Nothing
    End If
    
    GoTo ExitLab

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