📄 dlgaffirm.frm
字号:
BackStyle = 0 'Transparent
Caption = "家庭电话："
Height = 255
Left = 15
TabIndex = 47
Top = 4575
Width = 1365
End
Begin VB.Label Label25
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "办公电话："
Height = 255
Left = 15
TabIndex = 46
Top = 4995
Width = 1365
End
Begin VB.Label Label26
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "移动电话："
Height = 255
Left = 15
TabIndex = 45
Top = 5415
Width = 1365
End
Begin VB.Label Label27
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "联系地址："
Height = 255
Left = 15
TabIndex = 44
Top = 7095
Width = 1365
End
Begin VB.Label Label28
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "邮政编码："
Height = 255
Left = 15
TabIndex = 43
Top = 6255
Width = 1365
End
Begin VB.Label Label29
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "体检日期："
Height = 255
Left = 15
TabIndex = 42
Top = 6675
Width = 1365
End
Begin VB.Label Label19
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "身份证号："
Height = 255
Left = 15
TabIndex = 41
Top = 4155
Width = 1365
End
Begin VB.Label Label30
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "性别："
ForeColor = &H0000C000&
Height = 255
Left = 15
TabIndex = 40
Top = 2895
Width = 1365
End
Begin VB.Label Label32
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "年龄："
ForeColor = &H0000C000&
Height = 255
Left = 15
TabIndex = 39
Top = 3735
Width = 1365
End
Begin VB.Label Label17
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "婚否："
ForeColor = &H0000C000&
Height = 255
Left = 15
TabIndex = 38
Top = 3315
Width = 1365
End
Begin VB.Label Label34
BackStyle = 0 'Transparent
Caption = "cm"
Height = 255
Left = 6570
TabIndex = 37
Top = 4290
Visible = 0 'False
Width = 465
End
Begin VB.Label Label95
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "岁"
Height = 255
Left = 2100
TabIndex = 36
Top = 3750
Width = 315
End
Begin VB.Label Label64
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "所属团体："
ForeColor = &H00FF0000&
Height = 255
Left = 15
TabIndex = 35
Top = 2055
Width = 1365
End
Begin VB.Label Label33
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "电子邮件："
Height = 255
Index = 0
Left = 15
TabIndex = 34
Top = 5835
Width = 1365
End
Begin VB.Label lblGSelfBH
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "档案号："
Height = 255
Left = 45
TabIndex = 33
Top = 1215
Width = 1335
End
Begin VB.Label Label40
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "当日体检序号："
Height = 255
Index = 0
Left = 2400
TabIndex = 32
Top = -15
Visible = 0 'False
Width = 1365
End
Begin VB.Label Label41
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "所属分组："
ForeColor = &H00FF0000&
Height = 255
Left = 15
TabIndex = 31
Top = 2475
Width = 1365
End
End
Begin VB.Label Label40
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "体检序号："
Height = 255
Index = 3
Left = 6960
TabIndex = 76
Top = 480
Width = 1365
End
Begin VB.Label lblCount
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "Label1"
ForeColor = &H80000008&
Height = 255
Left = 90
TabIndex = 55
Top = 8760
Width = 3855
End
End
Attribute VB_Name = "FrmAffirm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType
Dim arrYYID() As String '团体的预约ID数组，用于录入个人信息时使用
Dim arrFZ() As Integer '某团体的分组ID数组
Dim mnodChecked As Node
Dim mblnChecked As Boolean
Dim mintAffirm As Integer '当日已确认人数
Dim mintNotAffirm As Integer '当日未确认人数
Dim mblnAdd As Boolean '当前是否添加
Dim mblnBuCha As Boolean '是否补查
Dim mlngBuChaGUID As Long
Private Const lngAffirm As Long = &H98FB98 '确认后的背景
Private Const lngNotAffirm As Long = &HCBC0FF ' &H29C153 '未确认后的背景
'****************20040406加入 闻*************************
Dim mintGrid As Integer
Dim mstrStatus As String
'****************20040406加入 闻*************************
'用于在确认中存该人的会员卡号
Dim mTmpHYKH As String
'****************20040628加入 闻************************
'记录是否是复查
Public mblnReCheck As Boolean
'****************20040628加入 闻************************
Dim m_enuCheckType As CheckType
Dim clsPrintBarCode As clsBarCode
Dim m_blnSystemID As Boolean
Dim m_blnSelfID As Boolean
Dim m_strOldQuery As String '记录上次查询结果
Dim m_blnCompute As Boolean '是否允许计算价格
Dim m_strPhotoFile As String
Dim m_strScanFile As String
Private Sub CmbFZ_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim i As Integer
Dim strDXID As String
Dim blnHave As Boolean
Dim strHealthID As String
Dim intFZID As Integer
' '根据该分组的体检日期更新dtpGTJRQ数值
' strSQL = "select * from FZ_FZSY" _
' & " where YYID='" & arrYYID(cmbGDWei.ListIndex) & "'" _
' & " and FZID=" & arrFZ(CmbFZ.ListIndex + 1)
' Set rsTemp = New ADODB.Recordset
' rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
' If rsTemp.RecordCount = 1 Then
' If rsTemp("FZTJRQ") >= Date Then
' dtpGTJRQ.Value = rsTemp("FZTJRQ")
' Else
' dtpGTJRQ.Value = Date
' End If
' End If
'***************20040514加入***********************
'先清除项目树tvwGDXiang的选取
For i = 1 To tvwGDXiang.Nodes.Count
tvwGDXiang.Nodes(i).Checked = False
Next
'***************20040514加入***********************
If (mblnAdd = True) And (mblnReCheck = False) Then
'根据该分组的体检日期更新txtTJXH和txtGYYID
strHealthID = Format(dtpGTJRQ.Value, "yyyymmdd")
strSQL = "select SJYYXLH from YY_XLH where RiQi='" & dtpGTJRQ.Value & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount = 0 Then
strHealthID = strHealthID & "0001"
txtTJXH.Text = 1
ElseIf IsNull(rstemp("SJYYXLH")) Then
strHealthID = strHealthID & "0001"
txtTJXH.Text = 1
rstemp.Close
Else
strHealthID = strHealthID & LongToString(rstemp("SJYYXLH") + 1, 4)
txtTJXH.Text = rstemp("SJYYXLH") + 1
rstemp.Close
End If
Set rstemp = Nothing
txtGYYID.Text = strHealthID
End If
'显示该分组所选择的体检项目
strSQL = "select * from YY_TJDJTC" _
& " where YYID='" & arrYYID(cmbGDWei.ListIndex) & "'" _
& " and FZID=" & arrFZ(Val(CmbFZ.ItemData(CmbFZ.ListIndex)))
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'如果XZTC字段为1，则说明选择了套餐,则将cmbTTCan中显示相应套餐
If rstemp.RecordCount = 1 Then
If rstemp("XZTC") = True Then
For i = 0 To cmbGTCan.ListCount - 1
If cmbGTCan.ItemData(i) = Val(rstemp("TCID")) Then
cmbGTCan.ListIndex = i
Exit For
End If
Next
Else
cmbGTCan.ListIndex = 0
End If
End If
'显示该分组所选的大项
strSQL = "select DXID from YY_TJDJDX" _
& " where YYID='" & arrYYID(cmbGDWei.ListIndex) _
& "' and FZID=" & arrFZ(Val(CmbFZ.ItemData(CmbFZ.ListIndex)))
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
If rstemp.RecordCount > 0 Then
For i = 1 To tvwGDXiang.Nodes.Count
strDXID = Mid(tvwGDXiang.Nodes(i).Key, 2)
If Len(strDXID) = 4 Then
rstemp.MoveFirst
blnHave = False
Do
If strDXID = rstemp("DXID") Then
blnHave = True
Exit Do
End If
rstemp.MoveNext
Loop Until rstemp.EOF
If blnHave = True Then
tvwGDXiang.Nodes(i).Checked = True
Else
tvwGDXiang.Nodes(i).Checked = False
End If
End If
Next
rstemp.Close
Else
For i = 1 To tvwGDXiang.Nodes.Count
tvwGDXiang.Nodes(i).Checked = False
Next
End If
'**************************20040411加入 闻********************************
mstrStatus = "change"
'**************************20040411加入完 闻******************************
Exit Sub
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
End Sub
Private Sub CmbFZ_KeyPress(KeyAscii As Integer)
EnterToTab KeyAscii
End Sub
Private Sub cmbGDWei_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim i As Integer
CmbFZ.Clear
'如果不选择单位，则表示是个散客登记
If cmbGDWei.Text = "" Then
' Me.dtpGTJRQ.Enabled = True
Me.dtpGTJRQ.Value = Date
End If
If cmbGDWei.Text <> "" Then '说明属于团体客户
'团体客户不允许修改套餐和体检标准
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -