📄 frmdwtjfy.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
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 FrmDWTJFY
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Caption = "单位体检费用"
ClientHeight = 7365
ClientLeft = 45
ClientTop = 330
ClientWidth = 11145
Icon = "FrmDWTJFY.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 7365
ScaleWidth = 11145
StartUpPosition = 1 '所有者中心
Begin VB.Frame Frame1
BackColor = &H80000018&
Caption = "体检单位"
Height = 7125
Left = 60
TabIndex = 5
Top = 90
Width = 4335
Begin MSComctlLib.ListView LvwDW
Height = 6765
Left = 60
TabIndex = 6
Top = 240
Width = 4215
_ExtentX = 7435
_ExtentY = 11933
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = 12648384
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 3
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "单位名称"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "体检人数"
Object.Width = 1764
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "预约日期"
Object.Width = 1764
EndProperty
End
End
Begin VB.Frame Frame2
BackColor = &H80000018&
Height = 825
Left = 4500
TabIndex = 2
Top = 6390
Width = 6555
Begin XPControls.XPCommandButton cmdPrint
Height = 465
Left = 1440
TabIndex = 3
Top = 210
Width = 1275
_ExtentX = 2249
_ExtentY = 820
Enabled = 0 'False
Caption = "打印(&P)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton cmdExit
Cancel = -1 'True
Height = 465
Left = 4080
TabIndex = 4
Top = 210
Width = 1275
_ExtentX = 2249
_ExtentY = 820
Caption = "退出(&X)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
End
Begin VB.Frame Frame3
BackColor = &H80000018&
Caption = "费用明细"
Height = 5535
Left = 4500
TabIndex = 0
Top = 720
Width = 6555
Begin VB.TextBox TxtFY
Height = 285
Left = 3270
TabIndex = 9
Top = 5460
Visible = 0 'False
Width = 1365
End
Begin VB.TextBox TxtZKL
Height = 285
Left = 960
TabIndex = 7
Top = 5460
Visible = 0 'False
Width = 915
End
Begin XPControls.XPCommandButton cmdCal
Height = 315
Left = 5220
TabIndex = 11
Top = 5430
Visible = 0 'False
Width = 795
_ExtentX = 1402
_ExtentY = 556
Caption = "计算"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSComctlLib.ListView LvwFYMX
Height = 5175
Left = 60
TabIndex = 12
Top = 240
Width = 6405
_ExtentX = 11298
_ExtentY = 9128
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = 16777215
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 5
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "姓名"
Object.Width = 2119
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "性别"
Object.Width = 1236
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "年龄"
Object.Width = 1236
EndProperty
BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 3
Text = "加项费用"
Object.Width = 1764
EndProperty
BeginProperty ColumnHeader(5) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 4
Text = "其中团体支付"
Object.Width = 2716
EndProperty
End
Begin VB.Label Label3
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "元"
Height = 225
Left = 4620
TabIndex = 10
Top = 5520
Visible = 0 'False
Width = 255
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "实际费用："
Height = 225
Left = 2280
TabIndex = 8
Top = 5520
Visible = 0 'False
Width = 975
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "折扣率："
Height = 225
Left = 60
TabIndex = 1
Top = 5490
Visible = 0 'False
Width = 885
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5190
Top = 3150
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label lblMemo
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 525
Left = 4530
TabIndex = 13
Top = 120
Width = 6495
End
End
Attribute VB_Name = "FrmDWTJFY"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim dblTotal As Long
Dim m_strTotal_Need As String
Dim m_strTotal_Payed As String
Dim m_strTotal_Lost As String
Private Sub cmdCal_Click()
Dim dblTmpFY As Long
Dim dblTmpZKL
Dim intPos As Integer
If TxtFY.Text <> "" Then '如果是从实际费用推算折扣率
dblTmpZKL = CDbl(TxtFY.Text) / dblTotal
If InStr(1, CStr(dblTmpZKL), ".", vbTextCompare) > 0 And Len(CStr(dblTmpZKL)) > 6 Then
'如果计算出的折扣率有小数并且位数大于六位
If Left(CStr(dblTmpZKL), 1) = "." Then
TxtZKL.Text = "0" & Mid(CStr(dblTmpZKL), 1, 5)
Else
TxtZKL.Text = Mid(CStr(dblTmpZKL), 1, 5)
End If
Else
TxtZKL.Text = CStr(dblTmpZKL)
End If
ElseIf TxtZKL.Text <> "" Then
dblTmpFY = CDbl(TxtZKL.Text) * dblTotal
If InStr(1, CStr(dblTmpFY), ".", vbTextCompare) > 0 Then
'如果计算出的实际费用当中有小数点
intPos = InStr(1, CStr(dblTmpFY), ".", vbTextCompare)
TxtFY.Text = Mid(CStr(dblTmpFY), 1, intPos + 2)
Else
'如果无小数点
TxtFY.Text = CStr(dblTmpFY)
End If
Else
MsgBox "请输入折扣率或实际费用", vbInformation, "提示"
End If
TxtFY.Locked = False
TxtZKL.Locked = False
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdPrint_Click()
If Me.lvwDW.ListItems.Count <= 0 Then Exit Sub
If lvwDW.SelectedItem Is Nothing Then
MsgBox "请选择需打印清单的团体！", vbInformation, "提示"
Else
PrintReport
End If
End Sub
Private Sub Form_Load()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim itmDW As ListItem
Dim rsTempRS As ADODB.Recordset
Screen.MousePointer = vbHourglass
strSQL = "select YYID,YY_TJDJ.TJRQ,DWMC,LXR as 体检人数 from YY_TJDJ,SET_DW" _
& " where YY_TJDJ.DWID=SET_DW.DWID" _
& " and YY_TJDJ.SFTJ in (1,2)" _
& " order by TJRQ desc" '按体检日期降序排列
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount > 0 Then
rstemp.MoveFirst
Do
Set itmDW = lvwDW.ListItems.Add(, "W" & rstemp("YYID"), rstemp("DWMC"))
Set rsTempRS = New ADODB.Recordset
rsTempRS.Open "select count(*) as 体检人数 from SET_GRXX where YYID='" & rstemp("YYID") & "'", GCon, adOpenStatic, adLockReadOnly
itmDW.SubItems(1) = rsTempRS("体检人数")
itmDW.SubItems(2) = rstemp("TJRQ")
rstemp.MoveNext
Loop Until rstemp.EOF
rstemp.Close
'选中第一个单位
Set lvwDW.SelectedItem = lvwDW.ListItems(1)
lvwDW_Click
End If
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Screen.MousePointer = vbDefault
End Sub
Public Sub PrintReport()
On Error GoTo Print_Cancel
Dim Status
Dim Msg As String
Dim PrintNummber As Integer
Dim i As Integer, j As Integer
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
' 是否已经注册
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
If gblnRegister = False Then
MsgBox "您使用的是未注册版本，不能使用该功能，请通过“系统设置”->“系统注册”进行注册！", vbInformation, "提示"
Exit Sub
End If
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlPDCollate Or cdlPDNoSelection ' cdlPDUseDevModeCopies
'CommonDialog1.Flags = cdlPDPageNums
CommonDialog1.Min = 1
CommonDialog1.Max = 1
CommonDialog1.FromPage = 1
CommonDialog1.ToPage = 1
CommonDialog1.ShowPrinter
On Error Resume Next
Printer.Copies = CommonDialog1.Copies
If Printer.Copies < 1 Then Printer.Copies = 1
'纵向走纸
Printer.Orientation = cdlPortrait
On Error GoTo Print_Cancel
'设成A4纸
Err.Clear
Printer.ScaleMode = vbMillimeters
Printer.ScaleWidth = 210
Printer.ScaleHeight = 297
'调用打印程序
'打印选中的记录
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -