frmset_rec.frm
来自「VB写的通过串口与考勤机连接通讯的程序」· FRM 代码 · 共 455 行
FRM
455 行
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmSet_rec
BackColor = &H00FFC0C0&
BorderStyle = 3 'Fixed Dialog
Caption = " 读取考勤记录"
ClientHeight = 2835
ClientLeft = 3495
ClientTop = 2850
ClientWidth = 6075
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
ScaleHeight = 2835
ScaleWidth = 6075
ShowInTaskbar = 0 'False
Begin VB.CommandButton cmdCancel
Caption = "取消"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3600
TabIndex = 10
Top = 2160
Width = 1095
End
Begin VB.Frame Frame1
BackColor = &H00FFC0C0&
Height = 975
Left = 720
TabIndex = 2
Top = 120
Width = 4815
Begin VB.TextBox txtSecond
Appearance = 0 'Flat
BackColor = &H00FFC0C0&
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3078
TabIndex = 6
Text = "Text2"
Top = 300
Width = 855
End
Begin VB.TextBox txtMinute
Appearance = 0 'Flat
BackColor = &H00FFC0C0&
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 1556
TabIndex = 3
Text = "Text1"
Top = 300
Width = 855
End
Begin VB.Label Label3
BackColor = &H00FFC0C0&
Caption = "秒"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 4080
TabIndex = 7
Top = 360
Width = 495
End
Begin VB.Label Label2
BackColor = &H00FFC0C0&
Caption = "分"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 2557
TabIndex = 5
Top = 360
Width = 375
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00FFC0C0&
Caption = "使用时间："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 120
TabIndex = 4
Top = 367
Width = 1290
End
End
Begin MSCommLib.MSComm MSComm1
Left = 120
Top = 360
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
BaudRate = 2400
InputMode = 1
End
Begin VB.CommandButton cmdRec
Caption = "录入数据"
Default = -1 'True
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 1080
TabIndex = 1
Top = 2160
Width = 1215
End
Begin MSComctlLib.ProgressBar Bar
DragIcon = "frmSet_rec.frx":0000
Height = 375
Left = 1320
TabIndex = 0
Top = 1320
Width = 3375
_ExtentX = 5953
_ExtentY = 661
_Version = 393216
BorderStyle = 1
Appearance = 1
End
Begin VB.Label LabFlish
BackColor = &H00FFC0C0&
Caption = "完成录入"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 2640
TabIndex = 9
Top = 1800
Width = 975
End
Begin VB.Label LabCount
BackColor = &H00FFC0C0&
Caption = " ％"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 3840
TabIndex = 8
Top = 1800
Width = 855
End
End
Attribute VB_Name = "frmSet_rec"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim SendByte(1 To 2) As Byte
Dim Recchar() As Byte
Dim Year_Now, cMonth, cDay, cHour, cMinute, cSecond, cCardID, cType As String
Dim InIT As Integer
Dim LastDay As Date
Dim J, Number, Num As Integer
Dim UpHour, DownHour, UpMinute, DownMinute, JiaBanTime, KuangQinTime As Integer
Private Sub cmdCancel_Click()
MSComm1.PortOpen = False
Set adoRs = Nothing
Unload Me
End Sub
Private Sub cmdRec_Click()
'On Error GoTo Errmsg
Bar.Visible = True
LabCount.Visible = True
LabFlish.Visible = True
'MSComm1.InBufferCount = 0
Dim Time As Long
Number = 0
aa = MSComm1.Input
Time = GetTickCount
SendByte(1) = 250
SendByte(2) = 185
Do While Number < 9
MSComm1.Output = SendByte
T = GetTickCount
Do
DoEvents
Loop Until GetTickCount - T > 60
Recchar = MSComm1.Input
If UBound(Recchar) < 0 Then
Number = Number + 1
Else
cType = "正常"
For I = LBound(Recchar) To UBound(Recchar)
SS = Hex(Recchar(I))
If Len(SS) = 1 Then
SS = "0" + SS
End If
Select Case I
Case 0
cCardID = SS
Case 1
cCardID = cCardID + SS
Case 2
cMonth = SS
Case 3
cMonth = cMonth + SS
Case 4
cHour = SS
Case 5
cMinute = SS
Case 6
cSecond = SS
Case 7
End Select
Next I
cCardID = CStr(Val(cCardID))
If Left(cMonth, 1) = "8" Then
cMonth = Year_Now + "-0" + Mid(cMonth, 2, 1) + "-" + Right(cMonth, 2)
Else
cMonth = Year_Now + "-1" + Mid(cMonth, 2, 1) + "-" + Right(cMonth, 2)
End If
'是否有效数据
If cHour = "07" And cMinute = "F9" And cSecond = "FF" Then
Else
If cHour < 12 Then '上午
Set adoRs = adoCon.Execute("exec Hour_proc '" & Trim(cCardID) & "' ,'" & Trim(cMonth) & "'")
If adoRs.EOF Then
If (Val(cHour) > UpHour) Or (Val(cHour) = UpHour And Val(cMinute) > UpMinute) Then
cType = "迟到"
If (Val(cHour) * 60 - UpHour * 60 + Val(cMinute) - UpMinute) > KuangQinTime Then
cType = "旷勤半天"
End If
Else
cType = "正常"
End If
adoCon.Execute ("exec InsertKS_proc '" & cCardID & "','" & cMonth & "','" & cHour & "','" & cMinute & "','" & cSecond & "','" & cType & "'")
End If
Else '下午
'早退
If (Val(cHour) < DownHour) Or (Val(cHour) = DownHour And Val(cMinute)) < DownMinute Then
cType = "早退"
If ((DownHour) * 60 - Val(cHour) * 60 + (DownMinute) - Val(cMinute)) > KuangQinTime Then
cType = "旷勤半天"
End If
Else
cType = "正常"
'加班
If (Val(cHour) * 60 + Val(cMinute)) > Val(JiaBanTime) Then
cType = "加班"
End If
End If
adoCon.Execute ("delete KaoQinsource where Hour>'12' and CardID='" & Trim(cCardID) & "' and Date='" & Trim(cMonth) & "'")
adoCon.Execute ("exec InsertKS_proc '" & cCardID & "','" & cMonth & "','" & cHour & "','" & cMinute & "','" & cSecond & "','" & cType & "'")
End If
Bar.Value = Bar.Value + 1
End If
End If
Loop
'缺勤查询、请假、公休日
Call InPutKaoQin
'加入请假信息
'数据库中有的是每人每天有一条记录,但是也特别的---迟到和早退在一天所以有两条记录
tt = GetTickCount
MM = Int(((tt - Time) / 1000) / 60)
SS = (tt - Time) / 1000 Mod 60
txtMinute.Text = MM
txtSecond.Text = SS
Bar.Visible = False
LabCount.Visible = False
LabFlish.Visible = False
MsgBox "录入结束，共计录入" + CStr(Num) + "条记录！" + Chr(13) + "使用时间为" + STR(MM) + "分" + STR(SS) + "秒", vbOKOnly, "系统提示"
Number = 10
MSComm1.PortOpen = False
Unload Me
'Errmsg:
' If Err.Number <> 0 Then
' MsgBox "有误？"
' Exit Sub
' End If
End Sub
Private Sub Command1_Click()
Dim cType(1 To 5) As String
cType(1) = "迟到"
cType(2) = "早退"
cType(3) = "加班"
cType(4) = "正常"
cType(5) = "旷勤半天"
For I = 1 To 365 * 20 * 2
Dim cDay As String
cDay = "2002-" + STR(Int(12! * Rnd() + 1)) + "-" + STR(Int(28! * Rnd() + 1))
adoCon.Execute ("insert into KaoQinSource values('" & Int(5! * Rnd() + 1) & "','" & Trim(cDay) & "','" & Int(24! * Rnd()) & "','" & Int(60! * Rnd()) & "','" & Int(60! * Rnd()) & "','" & cType(Int(5! * Rnd() + 1)) & "')")
Next I
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''为后来的请假程序'''''''''''''''''''''''''''
'Set adoRs = adoCon.Execute("select * from QingJia")
'Set adoRR = adoCon.Execute()
'Do While Not adoRs.EOF
' adoCon.Execute ("update KaoQin set Type='" & Trim(adoRs!Type) & "' where Date='" & Trim(adoRs!Date) & "' and CardID='" & Trim(adoRs!CardID) & "' and Type<>'正常'")
' adoRs.MoveNext
'Loop
'
'
'
'''''''''到时间自动提示删除信息90天前的
'Dim SS As Date
' Set adoRs = adoCon.Execute("select Date from KaoQing")
' SS = CDate(adoRs!Date)
' If Date Then
End Sub
Private Sub Form_Load()
Dim SendCount(1 To 2) As Byte
Dim Buf As String
Num = 0
LabCount.Visible = False
Bar.Visible = False
LabFlish.Visible = False
txtMinute.Text = ""
txtSecond.Text = ""
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2 - 900
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
MSComm1.PortOpen = True
Set adoRs = adoCon.Execute("select * from Time where Type='Nom' ")
UpHour = adoRs!UpHour
UpMinute = adoRs!UpMin
DownHour = adoRs!DownHour
DownMinute = adoRs!DownMin
Year_Now = Mid(Date$, 1, 4)
Set adoRs = adoCon.Execute("select * from Time where Type='JiaBan' ")
JiaBanTime = (DownHour + adoRs!UpHour) * 60 + (DownMinute + adoRs!UpMin)
Set adoRs = adoCon.Execute("select * from Time where Type='KuangQin' ")
KuangQinTime = adoRs!UpHour * 60 + adoRs!UpMin
SendCount(1) = 250
SendCount(2) = 177
MSComm1.Output = SendCount
T = GetTickCount
Do
DoEvents
Loop Until GetTickCount - T > 80
Recchar = MSComm1.Input
Buf = ""
For I = LBound(Recchar) To UBound(Recchar)
Buf = Hex(Recchar(I)) + Buf
Next I
Num = Val(Hex_D(Buf))
If Num <> 0 Then
Bar.Max = 2 * Num + 40
Bar.Min = 0
End If
End Sub
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?