📄 frm_rndtimecard.frm
字号:
strSQL2 = "insert into emplytmp select emplyid,serial from emply,depart where depart.dptid=emply.dptid and emply.empcrdyn=1 and dptname ='" & List1.List(i) & "'"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
Next i
strSQL2 = "select * from emplytmp"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
mancount = adoPrimaryRS2.RecordCount
'strSQL2 = "select emplytmp.emplyid,emplytmp.serial from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "' amd ((outdate is null) or (outdate<'" & DTPicker1(0).Value & "'))"
strSQL2 = "delete from emplytp"
mDB.ExecuteSQL strSQL2
'strSQL2 = "insert into emplytp select emplytmp.emplyid,emplytmp.serial from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "'"
strSQL2 = "insert into emplytp(emplyid,serial,indate,outdate) select emplytmp.emplyid,emplytmp.serial,indate,outdate from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "'"
mDB.ExecuteSQL strSQL2
strSQL = "delete from emplytp where serial is null or len(rtrim(serial))<1"
mDB.ExecuteSQL strSQL
strSQL2 = "select emplytp.emplyid,serial,flg from emplytp where (outdate is null) or (outdate>'" & DTPicker1(0).Value & "')"
'''strSQL2 = "select emplytp.emplyid,serial,flg from emplytp where serial is not null and (outdate is null) or (outdate>'" & DTPicker1(0).Value & "')"
'''Debug.Print strSQL2
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
If adoPrimaryRS2.RecordCount = 0 Then
MsgBox "你所选择的部门无员工，请重新选择。谢谢。", vbOKOnly, "NewAsia"
Exit Sub
Else
MsgBox "共有" & mancount & "_" & adoPrimaryRS2.RecordCount & "人参与考勤", vbOKOnly, "NewAsia"
End If
''''''60%人员加班；
'Dim iPer As Integer
'iPer = 60
'Dim iCount As Long
'iCount = CLng(adoprimaryRS2.RecordCount * iPer / 100)
'Dim RsCount As Long
'
'
'With adoprimaryRS2
' .MoveFirst
' RsCount = .RecordCount
' Do
' .Move CLng(RsCount * Rnd), 0
' .Fields("flg").Value = 1
' .Update
' RsCount = RsCount - 1
' .Filter = "flg<>1"
' .MoveFirst
' Loop Until RsCount < iCount
'End With
'adoprimaryRS2.Filter = "flg=1"
'MsgBox adoprimaryRS2.RecordCount & "加班。"
'strSQL2 = "delete from emplytmp"
'mDB.ExecuteSQL strSQL2
'
'For i = 0 To List1.ListCount - 1
'strSQL2 = "insert into emplytmp select emplyid,serial from emply,depart where depart.dptid=emply.dptid and emply.empcrdyn=1 and dptname ='" & List1.List(i) & "'"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'Next i
'
''GurhanButton1(0).BackColor = vbBlue
''GurhanButton1(0).BackColor = &H8000000F
'
'strSQL2 = "select * from emplytmp"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'
'strSQL2 = "select * from emplytmp"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'If adoPrimaryRS2.RecordCount = 0 Then
'MsgBox "你所选择的部门无员工，请重新选择。谢谢。", vbOKOnly, "NewAsia"
'Exit Sub
'Else
'MsgBox "共有" & adoprimaryRS.RecordCount & "人参与考勤", vbOKOnly, "NewAsia"
'End If
Screen.MousePointer = 11
bgtm = DTPicker1(0).Value & " " & SETIMER1(8).Text
t1 = DateDiff("n", SETIMER1(8).Text, SETIMER1(9).Text)
mDB.BeginTrans
adoPrimaryRS2.MoveFirst
Do Until adoPrimaryRS2.EOF
With adoprimaryRS
.AddNew
.Fields("crdtmid").Value = Maxid + 1
.Fields("emplyid").Value = adoPrimaryRS2.Fields("emplyid").Value
.Fields("empcrdno").Value = adoPrimaryRS2.Fields("serial").Value
.Fields("deviceid").Value = Int(Rnd * 2) + 1
.Fields("reasonid").Value = 0
.Fields("inorout").Value = 1
.Fields("cdatetime").Value = DateAdd("n", Int(t1 * Rnd) + 1, bgtm)
.Fields("isovertime").Value = 1
.Fields("recordtype").Value = 0
.Fields("operid").Value = "000001"
.Update
End With
Maxid = Maxid + 1
adoPrimaryRS2.MoveNext
Loop
bgtm = DTPicker1(0).Value & " " & SETIMER1(10).Text
t1 = DateDiff("n", SETIMER1(10).Text, SETIMER1(11).Text)
adoPrimaryRS2.MoveFirst
Do Until adoPrimaryRS2.EOF
With adoprimaryRS
.AddNew
.Fields("crdtmid").Value = Maxid + 1
.Fields("emplyid").Value = adoPrimaryRS2.Fields("emplyid").Value
.Fields("empcrdno").Value = adoPrimaryRS2.Fields("serial").Value
.Fields("deviceid").Value = Int(Rnd * 2) + 1
.Fields("reasonid").Value = 0
.Fields("inorout").Value = 0
.Fields("cdatetime").Value = DateAdd("n", Int(t1 * Rnd) + 1, bgtm)
.Fields("isovertime").Value = 1
.Fields("recordtype").Value = 0
.Fields("operid").Value = "000001"
.Update
End With
Maxid = Maxid + 1
adoPrimaryRS2.MoveNext
Loop
mDB.CommitTrans
Screen.MousePointer = 0
MsgBox "ok!"
Case 3
'Dim mancount As Integer
strSQL2 = "delete from emplytmp"
mDB.ExecuteSQL strSQL2
For i = 0 To List1.ListCount - 1
strSQL2 = "insert into emplytmp select emplyid,serial from emply,depart where depart.dptid=emply.dptid and emply.empcrdyn=1 and dptname ='" & List1.List(i) & "'"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
Next i
strSQL2 = "select * from emplytmp"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
mancount = adoPrimaryRS2.RecordCount
'strSQL2 = "select emplytmp.emplyid,emplytmp.serial from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "' amd ((outdate is null) or (outdate<'" & DTPicker1(0).Value & "'))"
strSQL2 = "delete from emplytp"
mDB.ExecuteSQL strSQL2
'strSQL2 = "insert into emplytp select emplytmp.emplyid,emplytmp.serial from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "'"
strSQL2 = "insert into emplytp(emplyid,serial,indate,outdate) select emplytmp.emplyid,emplytmp.serial,indate,outdate from emplytmp,emply2 where emplytmp.emplyid=emply2.emplyid and indate<='" & DTPicker1(0).Value & "'"
mDB.ExecuteSQL strSQL2
strSQL = "delete from emplytp where serial is null or len(rtrim(serial))<1"
mDB.ExecuteSQL strSQL
strSQL2 = "select emplytp.emplyid,serial,flg from emplytp where (outdate is null) or (outdate>'" & DTPicker1(0).Value & "')"
'''Debug.Print strSQL2
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
If adoPrimaryRS2.RecordCount = 0 Then
MsgBox "你所选择的部门无员工，请重新选择。谢谢。", vbOKOnly, "NewAsia"
Exit Sub
Else
MsgBox "共有" & mancount & "_" & adoPrimaryRS2.RecordCount & "人参与考勤", vbOKOnly, "NewAsia"
End If
'''''60%人员加班；
Dim iPer As Integer
'iPer = 60
iPer = iniFunc.sGetINI(App.Path & "\percent.ini", "Percent", "iPer", 60)
Dim SumCount As Long
Dim iCount As Long
SumCount = adoPrimaryRS2.RecordCount
iCount = CLng(adoPrimaryRS2.RecordCount * iPer / 100)
Dim RsCount As Long
With adoPrimaryRS2
.MoveFirst
RsCount = .RecordCount
Dim nRsCount As Integer
On Error Resume Next
Do
.Move CLng(RsCount * Rnd), 0
.Fields("flg").Value = 1
.Update
RsCount = RsCount - 1
.Filter = "flg<>1"
nRsCount = .RecordCount
If nRsCount Then
.MoveFirst
Else
Exit Do
End If
Loop Until RsCount < SumCount - iCount
End With
'strSQL2 = "delete from emplytmp"
'mDB.ExecuteSQL strSQL2
'
'For i = 0 To List1.ListCount - 1
'strSQL2 = "insert into emplytmp select emplyid,serial from emply,depart where depart.dptid=emply.dptid and emply.empcrdyn=1 and dptname ='" & List1.List(i) & "'"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'Next i
'
''GurhanButton1(0).BackColor = vbBlue
''GurhanButton1(0).BackColor = &H8000000F
'
'strSQL2 = "select * from emplytmp"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'
'strSQL2 = "select * from emplytmp"
'Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
'If adoPrimaryRS2.RecordCount = 0 Then
'MsgBox "你所选择的部门无员工，请重新选择。谢谢。", vbOKOnly, "NewAsia"
'Exit Sub
'Else
'MsgBox "共有" & adoprimaryRS.RecordCount & "人参与考勤", vbOKOnly, "NewAsia"
'End If
adoPrimaryRS2.Filter = "flg=1"
If MsgBox(adoPrimaryRS2.RecordCount & "加班。", vbYesNo) = vbNo Then
Screen.MousePointer = 0
Exit Sub
End If
Screen.MousePointer = 11
bgtm = DTPicker1(0).Value & " " & SETIMER1(8).Text
t1 = DateDiff("n", SETIMER1(8).Text, SETIMER1(9).Text)
mDB.BeginTrans
adoPrimaryRS2.MoveFirst
Do Until adoPrimaryRS2.EOF
With adoprimaryRS
.AddNew
.Fields("crdtmid").Value = Maxid + 1
.Fields("emplyid").Value = adoPrimaryRS2.Fields("emplyid").Value
.Fields("empcrdno").Value = adoPrimaryRS2.Fields("serial").Value
.Fields("deviceid").Value = Int(Rnd * 2) + 1
.Fields("reasonid").Value = 0
.Fields("inorout").Value = 1
.Fields("cdatetime").Value = DateAdd("n", Int(t1 * Rnd) + 1, bgtm)
.Fields("isovertime").Value = 1
.Fields("recordtype").Value = 0
.Fields("operid").Value = "000001"
.Update
End With
Maxid = Maxid + 1
adoPrimaryRS2.MoveNext
Loop
bgtm = DTPicker1(0).Value & " " & SETIMER1(10).Text
t1 = DateDiff("n", SETIMER1(10).Text, SETIMER1(11).Text)
adoPrimaryRS2.MoveFirst
Do Until adoPrimaryRS2.EOF
With adoprimaryRS
.AddNew
.Fields("crdtmid").Value = Maxid + 1
.Fields("emplyid").Value = adoPrimaryRS2.Fields("emplyid").Value
.Fields("empcrdno").Value = adoPrimaryRS2.Fields("serial").Value
.Fields("deviceid").Value = Int(Rnd * 2) + 1
.Fields("reasonid").Value = 0
.Fields("inorout").Value = 0
.Fields("cdatetime").Value = DateAdd("n", Int(t1 * Rnd) + 1, bgtm)
.Fields("isovertime").Value = 1
.Fields("recordtype").Value = 0
.Fields("operid").Value = "000001"
.Update
End With
Maxid = Maxid + 1
adoPrimaryRS2.MoveNext
Loop
mDB.CommitTrans
Screen.MousePointer = 0
MsgBox "ok!"
Case 4
GurhanButton1(0).BackColor = vbBlue
GurhanButton1(0).BackColor = &H8000000F
End Select
Exit Sub
Err1:
mDB.RollbackTrans
' MsgBox "可能是参与考勤的人员还没有发卡。即卡序列号为空——" & Err.Description & "----" & adoPrimaryRS2.Fields("emplyid").Value
DisPlayErr Err, "可能是参与考勤的人员还没有发卡。即卡序列号为空——----" & adoPrimaryRS2.Fields("emplyid").Value
End Sub
''''=======================================================
Private Sub List1_DblClick()
' List1.RemoveItem List1.ListIndex
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'If Button = 2 Then List1.Clear
If Button = 2 Then
''List1.Clear
Dim i As Integer
Dim ltmp As Long
On Error Resume Next
ltmp = oMenu.Popup("清除选定")
If ltmp = 1 Then
For i = 0 To List1.ListCount - 1
If List1.Selected(i) = True Then
''Debug.Print Val(Left(list1(0).List(I), InStr(list1(0).List(I), ",") - 1))
'strSQL3 = "update j_fac set ifx=false where fac_id=" & Val(Left(List1(0).List(i), InStr(List1(0).List(i), ",") - 1))
'mDB.ExecuteSQL strSQL3
''List1(1).AddItem List1(0).List(i)
'List1.RemoveItem List1.List(i)
List1.RemoveItem List1.ListIndex
End If
Next i
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -