📄 frmxiangmu.frm

📁 本系统可用于医院和专业体检中心的健康体检管理
💻 FRM
📖 第 1 页 / 共 4 页
字号:
上一页 1 2 34
End Sub

Private Sub optXXSMing_Click()
    EnableExpression False
End Sub

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

Private Sub optXXSZhi_Click()
    EnableExpression False
End Sub

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

Private Sub tvwSysXMu_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With tvwSysXMu
        If Not (.SelectedItem Is Nothing) Then
            If Len(.SelectedItem.Key) > 7 Then Set m_nodDraged = .SelectedItem
        End If
    End With
End Sub

Private Sub tvwSysXMu_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With tvwSysXMu
        If Not (.SelectedItem Is Nothing) Then
            If Len(.SelectedItem.Key) > 7 Then
                If Button = vbLeftButton Then '指示拖动操作。
                   m_blnInDrag = True '设置标志为 true。
                   '用 CreateDragImage 方法设置拖动图标。
                   .DragIcon = .SelectedItem.CreateDragImage
                   .Drag vbBeginDrag '拖动操作。
                End If
            End If
        End If
    End With
End Sub

Private Sub tvwSysXMu_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strKey As String
    Dim intSXH As Integer
    Dim i As Integer
    Dim intPos As Integer
    
    Me.MousePointer = vbHourglass
    
    cmdSave.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdAdd.Enabled = False
    
    If tvwSysXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwSysXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0 '根节点
            fraXX.Visible = False
        Case 2 '科室节点
            fraXX.Visible = False
        Case 7 '项目节点
            fraXX.Visible = True
            
            cmdAdd.Enabled = True
            
            EnableXXInput False
            
            '显示项目信息
            strSQL = "select * from SET_XX_SYSTEM" _
                    & " where XXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'            txtXXID.Text = rsTemp("XXID")
            txtXXMC.Text = rsTemp("XXMC")
            txtXXMC.Tag = rsTemp("XXMC") '记录Tag标志
            txtExpression.Text = "" '清除计算型表达式
            txtExpression.Tag = ""
            '是否含有图像
            chkHavePhoto.Value = vbUnchecked 'IIf(rsTemp("HavePhoto"), vbChecked, vbUnchecked)
            chkHavePhoto.Tag = "0" ' IIf(rsTemp("HavePhoto"), 1, 0)
            
            lblXMLX.Tag = "" '清空标识
            Select Case rsTemp("XXType")
                Case 0 '说明型
                    optXXSMing.Value = True
                    '记录项目类型。只记录说明型
                    lblXMLX.Tag = rsTemp("XXType") '便于修改
                Case 1 '数值型
                    optXXSZhi.Value = True
                Case 3 '计算型
                    optXXJSuan.Value = True
                    
                    If Not IsNull(rsTemp("XXExpression")) Then
                        intPos = InStr(1, rsTemp("XXExpression"), ",")
                        txtExpression.Text = Left(rsTemp("XXExpression"), intPos - 1)
                        txtExpression.Tag = Mid(rsTemp("XXExpression"), intPos + 1)
                    End If
                Case Else '
                    '
            End Select
            txtXXPYSX.Text = rsTemp("XXPYSX")
            txtXXPYSX.Tag = rsTemp("XXPYSX") '记录Tag标志
            txtXXPrice.Text = ""
            
            Select Case rsTemp("XXNNTY")
                Case 1
                    optXXMale.Value = True
                Case 2
                    optXXFemale.Value = True
                Case Else
                    optXXNNTY.Value = True
            End Select
            If rsTemp("XXSFJRXJ") = True Then
                optXJieYes.Value = True
            Else
                optXJieNo.Value = True
            End If
            
            If rsTemp("XXSFYJY") = True Then
                optJYiYes.Value = True
            Else
                optJYiNo.Value = True
            End If
            
            txtXXSM.Text = rsTemp("XXSM") & ""
            
            intSXH = rsTemp("SXH")
            '此处加入查询顺序号的语句
            strSQL = "select distinct SXH from SET_SXH" _
                    & " where SXH not in (" _
                        & "select SXH from SET_XX_SYSTEM" _
                        & " where left(XXID,2)='" & Left(rsTemp("XXID"), 2) & "'" _
                        & " and SXH<>" & intSXH _
                    & ")"
            
            '首先关闭前面打开的记录集
            rsTemp.Close
            '再次打开记录集，获取顺序号
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            '清空可能存在的显示
            cmbXXSXH.Clear
            For i = 1 To rsTemp.RecordCount
                cmbXXSXH.AddItem rsTemp("SXH")
                If rsTemp("SXH") = intSXH Then
                    cmbXXSXH.ListIndex = cmbXXSXH.NewIndex
                End If
                
                rsTemp.MoveNext
            Next
            
            m_blnIsSystem = True
            rsTemp.Close
            Set rsTemp = Nothing
    End Select
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub tvwXMu_DragDrop(Source As Control, X As Single, Y As Single)
    With tvwXMu
        If m_blnInDrag Then
            m_blnInDrag = False
            
            If (.DropHighlight Is Nothing) Or (m_nodDraged Is Nothing) Then
               Exit Sub
            Else
               Set .SelectedItem = .DropHighlight
               m_blnIsSystem = True
               Call cmdAdd_Click
               If cmdSave.Enabled Then Call cmdSave_Click
            End If
            
            Set .DropHighlight = Nothing
            Set m_nodDraged = Nothing
        End If
    End With
End Sub

Private Sub tvwXMu_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
    With tvwXMu
        If m_blnInDrag Then
           '设置 DropHighlight 为鼠标的坐标。
           Set .DropHighlight = .HitTest(X, Y)
        End If
    End With
End Sub

Private Sub tvwXMu_NodeClick(ByVal Node As MSComctlLib.Node)
'On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strKey As String
    Dim intSXH As Integer
    Dim i As Integer
    Dim intPos As Integer
    
    Me.MousePointer = vbHourglass
    
    m_blnIsSystem = False
    cmdSave.Enabled = False
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0 '根节点
            fraXX.Visible = False
            
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 2 '科室节点
            fraXX.Visible = False
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 7 '项目节点
            fraXX.Visible = True
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
            cmdModify.Enabled = True
            
            EnableXXInput False
            
            '显示项目信息
            strSQL = "select * from SET_XX" _
                    & " where XXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            txtXXID.Text = rsTemp("XXID")
            txtXXMC.Text = rsTemp("XXMC")
            txtXXMC.Tag = rsTemp("XXMC") '记录Tag标志
            txtExpression.Text = "" '清除计算型表达式
            txtExpression.Tag = ""
            '是否含有图像
            If Not IsNull(rsTemp("HavePhoto")) Then
                chkHavePhoto.Value = IIf(rsTemp("HavePhoto"), vbChecked, vbUnchecked)
                chkHavePhoto.Tag = IIf(rsTemp("HavePhoto"), 1, 0)
            Else
                chkHavePhoto.Value = vbUnchecked
                chkHavePhoto.Tag = 0
            End If
            
            
            lblXMLX.Tag = "" '清空标识
            Select Case rsTemp("XXType")
                Case 0 '说明型
                    optXXSMing.Value = True
                    '记录项目类型。只记录说明型
                    lblXMLX.Tag = rsTemp("XXType") '便于修改
                Case 1 '数值型
                    optXXSZhi.Value = True
                Case 3 '计算型
                    optXXJSuan.Value = True
                    
                    If Not IsNull(rsTemp("XXExpression")) Then
                        intPos = InStr(1, rsTemp("XXExpression"), ",")
                        txtExpression.Text = Left(rsTemp("XXExpression"), intPos - 1)
                        txtExpression.Tag = Mid(rsTemp("XXExpression"), intPos + 1)
                    End If
                Case Else '
                    '
            End Select
            txtXXPYSX.Text = rsTemp("XXPYSX")
            txtXXPYSX.Tag = rsTemp("XXPYSX") '记录Tag标志
            txtXXPrice.Text = rsTemp("XXPrice") & ""
            
            Select Case rsTemp("XXNNTY")
                Case 1
                    optXXMale.Value = True
                Case 2
                    optXXFemale.Value = True
                Case Else
                    optXXNNTY.Value = True
            End Select
            If rsTemp("XXSFJRXJ") = True Then
                optXJieYes.Value = True
            Else
                optXJieNo.Value = True
            End If
            
            If rsTemp("XXSFYJY") = True Then
                optJYiYes.Value = True
            Else
                optJYiNo.Value = True
            End If
            
            txtXXSM.Text = rsTemp("XXSM") & ""
            
            intSXH = rsTemp("SXH")
            '此处加入查询顺序号的语句
            strSQL = "select distinct SXH from SET_SXH" _
                    & " where SXH not in (" _
                        & "select SXH from SET_XX" _
                        & " where left(XXID,2)='" & Left(rsTemp("XXID"), 2) & "'" _
                        & " and SXH<>" & intSXH _
                    & ")"
            
            '首先关闭前面打开的记录集
            rsTemp.Close
            '再次打开记录集，获取顺序号
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            '清空可能存在的显示
            cmbXXSXH.Clear
            For i = 1 To rsTemp.RecordCount
                cmbXXSXH.AddItem rsTemp("SXH")
                If rsTemp("SXH") = intSXH Then
                    cmbXXSXH.ListIndex = cmbXXSXH.NewIndex
                End If
                
                rsTemp.MoveNext
            Next
            
            rsTemp.Close
            Set rsTemp = Nothing
    End Select
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用/禁用输入按钮
Private Sub EnableXXInput(ByVal blnFlag As Boolean)
    txtXXMC.Enabled = blnFlag
    optXXSMing.Enabled = blnFlag
    optXXSZhi.Enabled = blnFlag
    optXXJSuan.Enabled = blnFlag
    If (blnFlag) And (optXXJSuan.Value = True) Then
        EnableExpression True
    Else
        EnableExpression False
    End If
    chkHavePhoto.Enabled = blnFlag
    txtXXPYSX.Enabled = blnFlag
    txtXXPrice.Enabled = blnFlag
    cmbXXSXH.Enabled = blnFlag
    optXXNNTY.Enabled = blnFlag
    optXXMale.Enabled = blnFlag
    optXXFemale.Enabled = blnFlag
    optXJieNo.Enabled = blnFlag
    optXJieYes.Enabled = blnFlag
    optJYiNo.Enabled = blnFlag
    optJYiYes.Enabled = blnFlag
    txtXXSM.Enabled = blnFlag
    
    If m_blnIsSystem Then Call EnableSysPart(False)
End Sub

Private Sub txtExpression_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Clipboard.Clear
End Sub

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

Private Sub txtXXMC_LostFocus()
    txtXXPYSX.Text = Trim(txtXXPYSX.Text)
    If txtXXPYSX.Text = "" Then
        txtXXPYSX.Text = GetPYJM(txtXXMC.Text)
    End If
End Sub

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

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

Private Sub EnableExpression(ByVal blnFlag As Boolean)
    txtExpression.Enabled = blnFlag
    cmdExpression.Enabled = blnFlag
End Sub

Private Sub EnableSysPart(ByVal blnFlag As Boolean)
    txtXXMC.Enabled = blnFlag
    optXXSMing.Enabled = blnFlag
    optXXSZhi.Enabled = blnFlag
    optXXJSuan.Enabled = blnFlag
    txtExpression.Enabled = blnFlag
    cmdExpression.Enabled = blnFlag
    optXXNNTY.Enabled = blnFlag
    optXXMale.Enabled = blnFlag
    optXXFemale.Enabled = blnFlag
    optXJieNo.Enabled = blnFlag
    optXJieYes.Enabled = blnFlag
    optJYiNo.Enabled = blnFlag
    optJYiYes.Enabled = blnFlag
End Sub
上一页 1 2 34
⌨️ 快捷键说明

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