⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 formxmzh.frm

📁 本系统可用于医院和专业体检中心的健康体检管理
💻 FRM
📖 第 1 页 / 共 3 页
字号:
🔍
123 
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   4290
      TabIndex        =   12
      Top             =   750
      Width           =   945
   End
   Begin VB.Label Label6 
      BackStyle       =   0  'Transparent
      Caption         =   "小项列表："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   4470
      TabIndex        =   11
      Top             =   1320
      Width           =   975
   End
End
Attribute VB_Name = "FormXMZH"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmbDDXiang_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsXX As ADODB.Recordset
    
    lvwDestination.ListItems.Clear
    
    If cmbDDXiang.ListIndex < 0 Then Exit Sub
    
    '判断当前大项是否包含小项
    strSQL = "select DXSFYZX from SET_DX" _
            & " where DXID='" & LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        If rsXX(0) = 0 Then '无子项
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            
            Exit Sub
        Else '有子项
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
        End If
        rsXX.Close
    End If
    
    '获取当前选中大项的小项
    strSQL = "select XXID,XXMC from SET_XX" _
            & " where left(XXID,4)='" & LongToString(cmbDDXiang.ItemData(cmbDDXiang.ListIndex), 4) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        rsXX.MoveFirst
        Do
            lvwDestination.ListItems.Add , "W" & rsXX("XXID"), rsXX("XXMC")
            
            rsXX.MoveNext
        Loop Until rsXX.EOF
        rsXX.Close
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbDKShi_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    
    If cmbDKShi.ListIndex < 0 Then
        cmbDDXiang.Clear
        lvwDestination.ListItems.Clear
        
        Exit Sub
    End If
    
    '显示当前科室的所有大项（只显示有子项的大项）
    strSQL = "select DXID,DXMC from SET_DX" _
            & " where left(DXID,2)='" & LongToString(cmbDKShi.ItemData(cmbDKShi.ListIndex), 2) & "'" _
            & " and DXSFYZX=1"
    Set rsDX = New ADODB.Recordset
    rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    cmbDDXiang.Clear
    If rsDX.RecordCount > 0 Then
        rsDX.MoveFirst
        Do
            cmbDDXiang.AddItem rsDX("DXMC")
            cmbDDXiang.ItemData(cmbDDXiang.NewIndex) = rsDX("DXID")
            
            rsDX.MoveNext
        Loop Until rsDX.EOF
        rsDX.Close
        
        cmbDDXiang.ListIndex = 0
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbODXiang_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsXX As ADODB.Recordset
    
    lvwOriginal.ListItems.Clear
    
    If cmbODXiang.ListIndex < 0 Then Exit Sub
    
    '判断当前大项是否包含小项
    strSQL = "select DXSFYZX from SET_DX" _
            & " where DXID='" & LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        If rsXX(0) = 0 Then '无子项
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            
            Exit Sub
        Else '有子项
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
        End If
        rsXX.Close
    End If
    
    '获取当前选中大项的小项
    strSQL = "select XXID,XXMC from SET_XX" _
            & " where left(XXID,4)='" & LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        rsXX.MoveFirst
        Do
            lvwOriginal.ListItems.Add , "W" & rsXX("XXID"), rsXX("XXMC")
            
            rsXX.MoveNext
        Loop Until rsXX.EOF
        rsXX.Close
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbOKShi_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    
    If cmbOKShi.ListIndex < 0 Then
        cmbODXiang.Clear
        lvwOriginal.ListItems.Clear
        
        Exit Sub
    End If
    
'    cmbDKShi.Clear
'
'    '获取目的科室
'    strSQL = "select KSID,KSMC from SET_KSSZ" _
'            & " where KSID<>'" & LongToString(cmbOKShi.ItemData(cmbOKShi.ListIndex), 2) & "'"
'    '按顺序号排序
'    strSQL = strSQL & " order by SXH"
'    Set rsKShi = New ADODB.Recordset
'    rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    If rsKShi.RecordCount > 0 Then
'        rsKShi.MoveFirst
'        Do
'            cmbDKShi.AddItem rsKShi("KSMC")
'            cmbDKShi.ItemData(cmbDKShi.NewIndex) = rsKShi("KSID")
'
'            rsKShi.MoveNext
'        Loop Until rsKShi.EOF
'
'        cmbDKShi.ListIndex = 0
'    End If
    
    '显示当前科室的所有大项（只显示有子项的大项）
    strSQL = "select DXID,DXMC from SET_DX" _
            & " where left(DXID,2)='" & LongToString(cmbOKShi.ItemData(cmbOKShi.ListIndex), 2) & "'" _
            & " and DXSFYZX=1"
    Set rsDX = New ADODB.Recordset
    rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    cmbODXiang.Clear
    If rsDX.RecordCount > 0 Then
        rsDX.MoveFirst
        Do
            cmbODXiang.AddItem rsDX("DXMC")
            cmbODXiang.ItemData(cmbODXiang.NewIndex) = rsDX("DXID")
            
            rsDX.MoveNext
        Loop Until rsDX.EOF
        
        cmbODXiang.ListIndex = 0
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim rsXX As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim strXXID As String
    Dim intXXType As Integer
    Dim strXXPYSX As String
    Dim intSXH As Integer
    Dim strDMID As String '当前最大的数据字典编号
    
    '检查是否有可以移动的小项
    If lvwDestination.ListItems.Count < 1 Then Exit Sub
    
    If lvwDestination.SelectedItem Is Nothing Then Exit Sub
    
    '当前选中小项对方是否已经存在
    For i = 1 To lvwOriginal.ListItems.Count
        If lvwOriginal.ListItems(i).Text = lvwDestination.SelectedItem.Text Then
            MsgBox "当前小项已经存在！", vbInformation, "提示"
            Exit Sub
        End If
    Next
    
    '获取对方大项所包含小项的最大ID号
    strXXID = GetXXID(LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4))
    '获取对方大项未被占用的最小的顺序号
    strSQL = "select top 1 SXH from SET_SXH" _
            & " where SXH not in (" _
            & "select SXH from SET_XX" _
            & " where left(XXID,4)='" _
            & LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4) & "')" _
            & " order by SXH"
    '借用rsXX
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rsXX.EOF Then
        intSXH = rsXX("SXH")
        rsXX.Close
    Else
        intSXH = 300
    End If
    
    '添加一条空记录
    strSQL = "insert into SET_XX(XXID) values('" & strXXID & "')"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    '获取要拖动小项的全部信息
    strSQL = "select * from SET_XX" _
            & " where XXID='" & Mid(lvwDestination.SelectedItem.Key, 2) & "'"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsXX.RecordCount > 0 Then
        intXXType = rsXX("XXType")
        strXXPYSX = rsXX("XXPYSX")
        '
        strSQL = "update SET_XX set" _
                & " XXMC='" & rsXX("XXMC") & "'" _
                & ",KSID='" & LongToString(cmbOKShi.ItemData(cmbOKShi.ListIndex), 2) & "'" _
                & ",DXID='" & LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4) & "'" _
                & ",XXPYSX='" & rsXX("XXPYSX") & "'" _
                & ",XXWBSX='" & rsXX("XXWBSX") & "'" _
                & ",XXNNTY=" & IIf(IsNull(rsXX("XXNNTY")), 0, rsXX("XXNNTY")) _
                & ",XXType=" & IIf(IsNull(rsXX("XXType")), 0, rsXX("XXType")) _
                & ",XXCKSX='" & rsXX("XXCKSX") & "'" _
                & ",XXCKXX='" & rsXX("XXCKXX") & "'" _
                & ",XXDW='" & rsXX("XXDW") & "'" _
                & ",XXSFJRXJ=" & IIf(rsXX("XXSFJRXJ") = True, 1, 0) _
                & ",XXSFYJY=" & IIf(rsXX("XXSFYJY") = True, 1, 0) _
                & ",XXSM='" & rsXX("XXSM") & "'" _
                & ",SXH=" & intSXH _
                & " where XXID='" & strXXID & "'"
        rsXX.Close
        cmd.CommandText = strSQL
        cmd.Execute
        
        '以下在数据表中增加相应字段
        strSQL = "select DXPYSX from SET_DX" _
                & " where DXID='" & LongToString(cmbODXiang.ItemData(cmbODXiang.ListIndex), 4) & "'"
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
123

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -