frmxmsz_a.frm

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

            '获取该小项的拼音缩写
            strSQL = "select XXPYSX from SET_XX" _
                    & " where XXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsTemp.EOF Then
                MsgBox "无法获取当前小项的拼音缩写，请联系系统管理员，确认数据库是否遭到损坏！", vbInformation, "提示"
                GoTo ExitLab
            End If
            strXXPYSX = rsTemp("XXPYSX")
            rsTemp.Close
            
            '获取该小项所属大项的拼音缩写
            strSQL = "select DXPYSX from SET_DX" _
                    & " where DXID='" & Left(strKey, 4) & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsTemp.EOF Then
                MsgBox "无法获取当前小项所属大项的拼音缩写，请联系系统管理员，确认数据库是否遭到损坏！", vbInformation, "提示"
                GoTo ExitLab
            End If
            strDXPYSX = rsTemp("DXPYSX")
            rsTemp.Close
            
            '首先删除小项表中的记录
            strSQL = "delete from SET_XX" _
                    & " where XXID='" & strKey & "'"
            cmd.CommandText = strSQL
            cmd.Execute
            
            '接着删除大项数据表里的相应字段
            strSQL = "ALTER TABLE [DATA_" & strDXPYSX & "]" _
                    & " DROP COLUMN [" & strXXPYSX & "]"
            cmd.CommandText = strSQL
            cmd.Execute
            
            '删除体检标准
            strSQL = "delete from SET_TJBZDT" _
                    & " where XMID='" & strKey & "'"
            cmd.CommandText = strSQL
            cmd.Execute
            
             '*************************20040314*************
            '删除该小项对应的数据字典数据
            strSQL = "delete from DM_XX" _
                    & " where XXID='" & strKey & "'"
                    
            cmd.CommandText = strSQL
            cmd.Execute
            '*************************20040314*************

            intIndex = tvwXMu.SelectedItem.Index
            tvwXMu.Nodes.Remove intIndex
'            Set tvwXMu.SelectedItem = tvwXMu.Nodes(intIndex - 1)
            tvwXMuClick
    End Select
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = 0
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdModify_Click()
    Dim strKey As String
    
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请在左侧的树型中选择要修改的项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '记录关键字
    strKey = tvwXMu.SelectedItem.Key
    '去掉第一位
    strKey = Mid(strKey, 2)

    If Len(strKey) = 4 Then '大项
        SetAllDXInput True
        If optYZX.Value = True Then
            optYZX_Click
        Else
            optWZX_Click
        End If
        
        cmdModify.Enabled = False
        cmdDelete.Enabled = False
        cmdAdd.Enabled = False
        
        cmdSave.Enabled = True
        cmdOK.Enabled = True
        
        menuOperation = Modify
    ElseIf Len(strKey) = 7 Then '小项
        SetAllXXInput True
        
        cmdModify.Enabled = False
        cmdDelete.Enabled = False
        cmdAdd.Enabled = False
        
        cmdSave.Enabled = True
        cmdOK.Enabled = True
        
        menuOperation = Modify
    Else
        MsgBox "必须选择一个项目！", vbInformation, "提示"
    End If
    
ExitLab:
    Me.MousePointer = 0
End Sub



Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim arrStatus
    Dim strKey As String
    Dim rsTemp As New ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim strSQL As String
    Dim strDXPYSX As String
    Dim nodTemp As Node
    
    Me.MousePointer = 0
'
'    If Status = "READ" Then
'        GoTo 100
'    End If
    
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
'        MsgBox "请在左侧的树型中选择要修改的项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '记录关键字
    strKey = tvwXMu.SelectedItem.Key
    '去掉第一位
    strKey = Mid(strKey, 2)
    
    Select Case menuOperation
        '****************************************************
        '更改当前所选择的项目
        '****************************************************
        Case Modify
            If Len(strKey) = 4 Then '修改大项
                strSQL = "SELECT * FROM SET_DX WHERE DXID=" & "'" & strKey & "'"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
                If PutDXToRsDX(rsDX) = True Then
                    rsDX.Update
                    SetAllDXInput False
                    
                    tvwXMu.SelectedItem.Text = txtDXMC.Text
                    GoTo ExitLab
                Else
                    GoTo ExitLab
'                    rsDX.Close
                End If
                
            ElseIf Len(strKey) = 7 Then  '修改小项
                strSQL = "SELECT * FROM SET_XX WHERE XXID='" & strKey & "'"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
                If putXXToRsXX(rsXX) = True Then
                    rsXX.Update
                    SetAllXXInput False
                    tvwXMu.SelectedItem.Text = txtXXMC.Text
                    GoTo ExitLab
                Else
                    GoTo ExitLab
                End If
                
'                rsXX.Close
                
'                DrawNode
            End If
            cmdSave.Enabled = False
        '****************************************************
        '添加项目
        '****************************************************
        Case Add
            If Len(strKey) = 2 Then '添加大项
                strSQL = "SELECT * FROM SET_DX" _
                        & " where 1=0"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenDynamic, adLockOptimistic '返回一个空记录集
                rsDX.AddNew
                
                If PutDXToRsDX(rsDX) = True Then
                    rsDX.Fields("DXID") = txtDXID.Text
                    rsDX.Update
                Else
                    Set rsDX = Nothing
                    GoTo ExitLab
                End If
                rsDX.Close
                strSQL = "CREATE TABLE [DATA_" & txtDXPYSX.Text & "]" & _
                        " (GUID int PRIMARY KEY,TJRQ smalldatetime)"
                GCon.Execute strSQL
                If optWZX.Value = True Then
                    strSQL = "ALTER TABLE [DATA_" & txtDXPYSX.Text & "]" & _
                            " ADD [" & txtDXPYSX.Text & "Value]"
                    If optDXSMing.Value = True Then
                        strSQL = strSQL & " varchar(300) null"
                    Else
                        strSQL = strSQL & " varchar(10) null"
                    End If
                    
                    GCon.Execute strSQL
                End If
         
                SetAllDXInput False
                
                '添加到树型
                Set nodTemp = tvwXMu.Nodes.Add("W" & strKey, tvwChild, "W" & txtDXID.Text, txtDXMC.Text)
'                nodTemp.Visible = True
            ElseIf Len(strKey) = 4 Or Len(strKey) = 7 Then '添加小项
                strSQL = "SELECT * FROM SET_XX" _
                        & " where 1=0"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenDynamic, adLockOptimistic '返回一个空记录集
                rsXX.AddNew
                
                If putXXToRsXX(rsXX) = True Then
                    rsXX.Fields("XXID") = txtXXID.Text
                    rsXX.Update
                Else
                    Set rsXX = Nothing
                    GoTo ExitLab
                End If
                rsXX.Close
                
                '修改大项数据表增加一列，列名为小项的拼音缩写，如为数值型项目，则增加列的数据类型为varchar(10)
                '如为说明型项目，增加列数据类型为varchar(300)
                '获取所属大项拼音缩写
                strSQL = "select DXPYSX from SET_DX" _
                        & " where DXID='" & Left(strKey, 4) & "'"
                Set rsTemp = New ADODB.Recordset
                rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                strDXPYSX = rsTemp("DXPYSX")
                rsTemp.Close
                
                strSQL = "ALTER TABLE " & "[DATA_" & strDXPYSX & "] ADD [" & txtXXPYSX.Text & "]"
                If optXXSMing.Value = True Then '说明型小项
                    strSQL = strSQL & " VARCHAR(300) NULL"
                Else '数值型小项
                    strSQL = strSQL & " VARCHAR(10) NULL"
                End If
                GCon.Execute strSQL

                Set nodTemp = tvwXMu.Nodes.Add("W" & Left(strKey, 4), tvwChild, "W" & txtXXID.Text, txtXXMC.Text)
'                nodTemp.Visible = True
                
                SetAllXXInput False
            End If
            cmdSave.Enabled = False
    End Select
    
    tvwXMuClick
    
    MsgBox "保存成功！", vbInformation, "提示"
    
    GoTo ExitLab
'    CmdDel.Enabled = True
'    CmdChange.Enabled = True
'    CmdAdd.Enabled = True
'
'    CmdSave.Enabled = False
'    CmdOK.Enabled = False
ErrMsg:
    arrStatus = SetError(Err.Number, Err.Source, Err.Source)
    ErrMsg arrStatus
    
ExitLab:
    Me.MousePointer = 0
End Sub

Private Sub Command1_Click()
    Dim doc1 As New Document
    Dim bookText As String
    Documents.Open FileName:=".\zjqk.doc"
    Set doc1 = ActiveDocument
    If doc1.Bookmarks.Count >= 1 Then
        bookText = ActiveDocument.Bookmarks(1).Range.Text
        MsgBox bookText, , "提示"
    End If

End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    
    Screen.MousePointer = 11
    
    Me.Height = 8295
    Me.Width = 10245
    
    '添加一个根节点
    '关键字长度：1＝1
    Set nodTemp = tvwXMu.Nodes.Add(, , "W", "项目设置")
    nodTemp.Expanded = True
    
    '显示所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ"
    '按顺序号排序
    strSQL = strSQL & " order by SXH"
    Set rsKShi = New ADODB.Recordset
    rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsKShi.RecordCount > 0 Then
        rsKShi.MoveFirst
        Do
            '添加科室
            '关键字长度：1＋2＝3
            Set nodTemp = tvwXMu.Nodes.Add("W", tvwChild, "W" & rsKShi("KSID"), rsKShi("KSMC"))
'            nodTemp.Expanded = True
            
            strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
                    & " where left(DXID,2)='" & rsKShi("KSID") & "'"
            '按顺序号排序
            strSQL = strSQL & " order by SXH"
            Set rsDX = New ADODB.Recordset
            rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsDX.RecordCount > 0 Then
                rsDX.MoveFirst
                Do
                    '添加大项
                    '关键字长度：1＋4＝5
                    Set nodTemp = tvwXMu.Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
'                    nodTemp.Expanded = True
                    
                    If rsDX("DXSFYZX") = 1 Then '有子项
                        strSQL = "select XXID,XXMC from SET_XX" _
                                & " where left(XXID,4)='" & rsDX("DXID") & "'"
                        '按顺序号排序
                        strSQL = strSQL & " order by SXH"
                        Set rsXX = New ADODB.Recordset
                        rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
                        If rsXX.RecordCount > 0 Then
                            rsXX.MoveFirst
                            Do
                                '关键字长度：1＋7＝8
                                tvwXMu.Nodes.Add "W" & rsDX("DXID"), tvwChild, "W" & rsXX("XXID"), rsXX("XXMC")
'                                nodTemp.Expanded = True
                                
                                rsXX.MoveNext
                            Loop Until rsXX.EOF
                            rsXX.Close
                        End If
                    End If
                     
                    rsDX.MoveNext
                Loop Until rsDX.EOF
                rsDX.Close
            End If
            
            rsKShi.MoveNext
        Loop Until rsKShi.EOF
        rsKShi.Close
    End If