dlgitem.frm

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

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form dlgItem 
   BackColor       =   &H80000018&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "添加套餐项目"
   ClientHeight    =   6510
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   4875
   Icon            =   "dlgItem.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6510
   ScaleWidth      =   4875
   StartUpPosition =   2  'CenterScreen
   Begin MSComctlLib.TreeView tvwXMu 
      Height          =   5340
      Left            =   390
      TabIndex        =   3
      Top             =   390
      Width           =   4065
      _ExtentX        =   7170
      _ExtentY        =   9419
      _Version        =   393217
      HideSelection   =   0   'False
      LabelEdit       =   1
      Style           =   7
      Checkboxes      =   -1  'True
      Appearance      =   1
   End
   Begin XPControls.XPCommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   375
      Left            =   2670
      TabIndex        =   1
      Top             =   5940
      Width           =   1125
      _ExtentX        =   1984
      _ExtentY        =   661
      Caption         =   "取消"
      Font            =   "dlgItem.frx":0CCA
   End
   Begin XPControls.XPCommandButton cmdOK 
      Height          =   375
      Left            =   930
      TabIndex        =   0
      Top             =   5940
      Width           =   1125
      _ExtentX        =   1984
      _ExtentY        =   661
      Caption         =   "确定"
      Font            =   "dlgItem.frx":0CF6
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "请在需要进入套餐的项目前面打√："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   180
      Left            =   1080
      TabIndex        =   2
      Top             =   120
      Width           =   3105
   End
End
Attribute VB_Name = "dlgItem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdCancel_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub cmdOK_Click()
On Error GoTo ErrMsg
    Dim i As Integer
    
    With frmFormula.lstItem
        '首先清除
        .Clear
        '添加所有选择的项目
        For i = 1 To tvwXMu.Nodes.Count
            If Len(tvwXMu.Nodes(i).Key) = 5 Then '说明是大项
                If tvwXMu.Nodes(i).Checked = True Then
                    .AddItem tvwXMu.Nodes(i).Text
                    .ItemData(.NewIndex) = Mid(tvwXMu.Nodes(i).Key, 2)
                End If
            End If
        Next
        
        '检测是否选择了项目
        If .ListCount < 1 Then
            MsgBox "请选择要添加的项目！", vbInformation, "提示"
            Exit Sub
        End If
    End With
    
    cmdCancel_Click
    Exit Sub
ErrMsg:
    '
End Sub

'被frmFormula调用
'当修改时，第二个参数为修改套餐的ID
Public Sub ShowItem(ByVal enuOperation As OperationType, Optional intTCID As Integer)
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 i As Integer, j As Integer
    
    Screen.MousePointer = 11
    
    '加载一个根节点
    '关键字长度：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
                    
                    rsDX.MoveNext
                Loop Until rsDX.EOF
                rsDX.Close
            End If
            
            rsKShi.MoveNext
        Loop Until rsKShi.EOF
        rsKShi.Close
    End If
    
    '更新的情况
    If enuOperation = Modify Then
        strSQL = "SELECT DXID FROM SET_TCDX" _
                & " WHERE TCID=" & intTCID
        Status = GetRows(strSQL)
        If ErrTrue(Status) Then
            ErrMsg Status
            Exit Sub
        End If
        
        With tvwXMu
            For i = 1 To .Nodes.Count
                If Len(.Nodes(i).Key) = 5 Then
                    RS.MoveFirst
                    For j = 1 To RS.RecordCount
                        If Mid(.Nodes(i).Key, 2) = RS("DXID") Then
                            .Nodes(i).Checked = True
                            Exit For
                        End If
                        RS.MoveNext
                    Next
                End If
            Next
        End With
    End If
    
    Screen.MousePointer = 0
    Me.Show vbModal
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, "加载套餐项目时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = 0
End Sub

Private Sub tvwXMu_NodeCheck(ByVal Node As MSComctlLib.Node)
    Dim i As Integer
    
    '判断有无子节点
    If Node.Children > 0 Then
        '是否选中
        If Node.Checked = True Then
            '循环检查每个子节点
            For i = 1 To tvwXMu.Nodes.Count
                If tvwXMu.Nodes(i).Parent Is Node Then
                    tvwXMu.Nodes(i).Checked = Node.Checked
                End If
            Next
        End If
    End If
End Sub