www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > frmMain.frm
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{FE0065C0-1B7B-11CF-9D53-00AA003C9CB6}#1.1#0"; "COMCT232.OCX"
Object = "{C932BA88-4374-101B-A56C-00AA003668DC}#1.1#0"; "MSMASK32.OCX"
Begin VB.Form frmMain
BorderStyle = 3 'Fixed Dialog
ClientHeight = 8190
ClientLeft = 150
ClientTop = 435
ClientWidth = 11880
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmMain.frx":0000
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
Moveable = 0 'False
ScaleHeight = 8190
ScaleWidth = 11880
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin MSMask.MaskEdBox medTime
Height = 345
Left = 3795
TabIndex = 70
Top = 5145
Visible = 0 'False
Width = 765
_ExtentX = 1349
_ExtentY = 609
_Version = 393216
BackColor = -2147483624
MaxLength = 5
Mask = "##:##"
PromptChar = "_"
End
Begin MSMask.MaskEdBox medDate
Height = 360
Left = 3555
TabIndex = 69
Top = 4605
Visible = 0 'False
Width = 1215
_ExtentX = 2143
_ExtentY = 635
_Version = 393216
BackColor = -2147483624
MaxLength = 10
Mask = "####-##-##"
PromptChar = "_"
End
Begin VB.TextBox txtEdit
BackColor = &H80000018&
Height = 360
Left = 3375
MaxLength = 4
TabIndex = 1
Top = 4050
Visible = 0 'False
Width = 1275
End
Begin MSFlexGridLib.MSFlexGrid msfGrid
Height = 4680
Left = 180
TabIndex = 0
Top = 3195
Width = 11535
_ExtentX = 20346
_ExtentY = 8255
_Version = 393216
Rows = 20
FixedCols = 0
BackColor = -2147483624
BackColorFixed = 12632256
ForeColorFixed = 12582912
BackColorBkg = -2147483624
FormatString = " Empty Then
If MsgBox("您还没保存,要保存吗?", vbQuestion + vbYesNo, gTitle) = vbYes Then
cmdEdit_Click gCMDSAVE
Exit Sub
End If
End If
Unload Me
Case mRefresh
RefreshHistory
End Select
End Sub
Private Function DeleteForLeave() As Boolean
Dim strWorkNo As String
Dim strSDate As String
Dim strSTime As String
Dim strEDate As String
Dim strETime As String
Dim Sql As String
If MsgBox(mMsg8, _
vbQuestion + vbOKCancel + vbDefaultButton2, _
gTitle) = vbCancel Then Exit Function
On Error GoTo DeleteErr
With msfGrid
strWorkNo = Trim(.TextMatrix(.row, mGridWorkNo))
strSDate = Trim(.TextMatrix(.row, mGridStartDate))
strSTime = Trim(.TextMatrix(.row, mGridStartTime))
strEDate = Trim(.TextMatrix(.row, mGridEndDate))
strETime = Trim(.TextMatrix(.row, mGridEndTime))
Sql = "Update "
If mStatus = gMAINLEAVE Then
Sql = Sql & "Leave"
ElseIf mStatus = gMAINABSENT Then
Sql = Sql & "Absent"
End If
Sql = Sql & " set F_DelFlag=" & gTRUE _
& " where WorkNo ='" & strWorkNo _
& "' and StartDate='" & strSDate _
& "' and StartTime='" & strSTime _
& "' and EndDate='" & strEDate _
& "' and EndTime='" & strETime & "'"
gDataBase.Execute Sql
DeleteForLeave = True
If .Rows = .FixedRows + 1 Then
.Rows = .FixedRows
Else
.RemoveItem .row
End If
End With
Exit Function
DeleteErr:
MsgBox mMsg9 & vbCrLf & vbCrLf & Err.Description, vbExclamation, gTitle
Err.Clear
DeleteForLeave = False
End Function
Private Sub ToModify()
With msfGrid
Dim i As Integer
Dim CellStr As String
mblnIsModify = True
For i = 0 To .Cols - 1
CellStr = Trim(.TextMatrix(.row, i))
Select Case i
Case 0 To 2
txtKQ(i) = CellStr
Case 3
txtKQ(mtxtDept) = CellStr
Case 4
txtKQ(mtxtTitle) = CellStr
Case mGridStartDate
txtKQ(mtxtSDate) = CellStr
Case mGridStartTime
txtKQ(mtxtSHour) = Left(CellStr, 2)
txtKQ(mtxtSMinute) = Right(CellStr, 2)
Case mGridEndDate
txtKQ(mtxtEDate) = CellStr
Case mGridEndTime
txtKQ(mtxtEHour) = Left(CellStr, 2)
txtKQ(mtxtEMinute) = Right(CellStr, 2)
Case mGridType
LookForCboByStr cboKQ, CellStr
Case mGridAllowMan
txtKQ(mtxtAllowMan) = CellStr
Case mGridReason
txtKQ(mtxtReason) = CellStr
End Select
Next
End With
ChangeColorFortxtKQ True
RefreshButton cmdEdit, gCMDEDIT
cmdEdit(mRefresh).Enabled = False
txtKQ(mtxtWorkNo).Locked = True
txtKQ(mtxtSDate).SetFocus
End Sub
Private Sub AfterSave()
InitxtEdit
ChangeColorFortxtKQ False
RefreshButton cmdEdit, gCMDEDITNORMAL
cmdEdit(mRefresh).Enabled = True
mblnIsModify = False
mblnIsAdd = False
mblnIsNeedSave = False
cmdEdit(gCMDAPPEND).Caption = gSTRAPPEND & "&A"
End Sub
Private Function SaveDataToDatabase() As Boolean
Dim strWorkNo As String
Dim strAllowMan As String
Dim strSDate As String
Dim strSTime As String
Dim strEDate As String
Dim strETime As String
Dim intLeaveType As Integer
Dim strReason As String
Dim isTrans As Boolean
strWorkNo = Trim(txtKQ(mtxtWorkNo))
strAllowMan = Trim(txtKQ(mtxtAllowMan))
strSDate = Trim(txtKQ(mtxtSDate))
strSTime = Format(Trim(txtKQ(mtxtSHour)), "00") & ":" _
& Format(Trim(txtKQ(mtxtSMinute)), "00")
strEDate = Trim(txtKQ(mtxtEDate))
strETime = Format(Trim(txtKQ(mtxtEHour)), "00") & ":" _
& Format(Trim(txtKQ(mtxtEMinute)), "00")
strReason = Trim(txtKQ(mtxtReason))
getItemData cboKQ, intLeaveType
If Not mblnIsModify Then
If strWorkNo = Empty Then
MsgBox "工号不能为空,请输入!!", , gTitle
SaveDataToDatabase = False
txtKQ(mtxtWorkNo).SetFocus
Exit Function
Else
If Trim(txtKQ(mtxtName)) = Empty Then
MsgBox "无效的工号,请核对后重新输入!!", , gTitle
SaveDataToDatabase = False
txtKQ(mtxtWorkNo).SetFocus
Exit Function
End If
End If
End If
If strAllowMan = Empty Then
If mStatus = gMAINLEAVE Then
MsgBox "没有批准人怎么能准假呢?,请输入!!", , gTitle
ElseIf mStatus = gMAINABSENT Then
MsgBox "批准人不能为空,请输入!!", , gTitle
End If
SaveDataToDatabase = False
txtKQ(mtxtAllowMan).SetFocus
Exit Function
End If
If strSDate = Empty Then
MsgBox "起始日期不能为空,请输入!!", , gTitle
SaveDataToDatabase = False
txtKQ(mtxtSDate).SetFocus
Exit Function
End If
If strEDate = Empty Then
MsgBox "截至日期不能为空,请输入!!", , gTitle
SaveDataToDatabase = False
txtKQ(mtxtEDate).SetFocus
Exit Function
End If
If (strSDate & strSTime) >= (strEDate & strETime) Then
MsgBox "起始日期时间不能大于或等于截至日期时间!!", , gTitle
SaveDataToDatabase = False
txtKQ(mtxtSDate).SetFocus
Exit Function
End If
If Not HasThisTable(gPlanTableName) Then
If Not CreatePlanTable Then
MsgBox mMsg7, vbCritical, gTitle
SaveDataToDatabase = False
Exit Function
End If
End If
Dim strOperateTime As String
strOperateTime = Format(Now, "yyyy-mm-dd hh:mm")
Dim Rst As Recordset
If mStatus = gMAINLEAVE Then
Set Rst = gDataBase.OpenRecordset("Leave")
ElseIf mStatus = gMAINABSENT Then
Set Rst = gDataBase.OpenRecordset("Absent")
End If
On Error GoTo SaveErr
BeginTrans
isTrans = True
If Not mblnIsModify Then
Rst.AddNew
Rst!WorkNo = strWorkNo
Else
Rst.Edit
End If
With Rst
!StartDate = strSDate
!StartTime = strSTime
!EndDate = strEDate
!EndTime = strETime
!UserID = gUserID
!AllowMan = strAllowMan
!OperateTime = strOperateTime
If mStatus = gMAINLEAVE Then
!TypeID = intLeaveType
!Reason = strReason
ElseIf mStatus = gMAINABSENT Then
!isEvection = intLeaveType
End If
.Update
End With
Rst.Close
' UpdateShiftPlan strSDate, strEDate, Trim(cboKQ.Text)
CommitTrans
isTrans = False
Set Rst = Nothing
SaveDataToDatabase = True
If Not mblnIsModify Then
Dim StrAdd As String
With msfGrid
StrAdd = strWorkNo & vbTab & Trim(txtKQ(mtxtName)) _
& vbTab & Trim(txtKQ(mtxtSex)) & vbTab _
& Trim(txtKQ(mtxtDept)) & vbTab _
& Trim(txtKQ(mtxtTitle)) & vbTab _
& strSDate & vbTab & strSTime & vbTab _
& strEDate & vbTab & strETime & vbTab _
& Trim(cboKQ.Text) & vbTab _
& strAllowMan & vbTab
If mStatus = gMAINLEAVE Then
StrAdd = StrAdd & strReason
End If
.AddItem StrAdd
.TopRow = .Rows - 1
End With
Else
With msfGrid
.TextMatrix(.row, mGridStartDate) = strSDate
.TextMatrix(.row, mGridStartTime) = strSTime
.TextMatrix(.row, mGridEndDate) = strEDate
.TextMatrix(.row, mGridEndTime) = strETime
.TextMatrix(.row, mGridType) = Trim(cboKQ.Text)
.TextMatrix(.row, mGridAllowMan) = strAllowMan
If mStatus = gMAINLEAVE Then
.TextMatrix(.row, mGridReason) = strReason
End If
End With
End If
DoPlan strWorkNo, Trim(txtKQ(mtxtName)), Trim(txtKQ(mtxtDept))
'MsgBox "恭喜!数据保存成功,请修改排班表", vbInformation, gTitle
Exit Function
SaveErr:
If isTrans Then
Rollback
MsgBox "数据未保存成功!请再试!! " & vbCrLf _
& vbCrLf & Err.Description, vbExclamation, gTitle
Else
MsgBox Err.Description, vbExclamation, gTitle
End If
Err.Clear
SaveDataToDatabase = False
' Rst.CancelUpdate
End Function
Private Sub DoPlan(strWorkNo As String, strName As String, strDeptName As String)
Dim MyfrmDetail As frmDetail
Set MyfrmDetail = New frmDetail
Dim strTemp As String
With MyfrmDetail
.mDeptID = Empty
.mWorkNo = strWorkNo
strTemp = mstrDui
strTemp = strTemp & "[" & strDeptName & "]" & mstrEmployee _
& "[" & strName & "]"
.mTitle = strTemp & mstrDoPlan
.mIsToLook = False
.Show vbModal
'If .mNeedToRefresh Then tvwPlan_NodeClick mNode
Unload MyfrmDetail
End With
End Sub
'Private Sub UpdateShiftPlan(strSDate As String, strEDate As String, strAbsentType As String)
' Dim intStartDay As Integer
' Dim intEndDay As Integer
' intStartDay = CInt(Var(Right(strSDate, 2)))
' intEndDay = CInt(Var(Right(strEDate, 2)))
' Dim IntDay As Integer
' Dim Sql As String
' For IntDay = intStartDay To intEndDay
' Sql = "update " & gPlanTableName & _
' " set F_Shift="
' If mStatus = gMAINLEAVE Then
' Sql = Sql & GSHIFTLEAVEID
' ElseIf mStatus = gMAINABSENT Then
' If strAbsentType = GSHIFTEVECTIONSTR Then
' Sql = Sql & GSHIFTEVECTIONID
' ElseIf strAbsentType = GSHIFTMONEYSTR Then
' Sql = Sql & GSHIFTMONEYID
' End If
' End If
' Sql = Sql & " Where WorkNo='" & strWorkNo & _
' "' and F_Day=" & IntDay
' gDataBase.Execute Sql
' Next
'End Sub
Private Sub AddAction()
RefreshButton cmdEdit, gCMDAPPEND
ChangeColorFortxtKQ True
End Sub
Private Sub ChangeColorFortxtKQ(isEdit As Boolean)
Dim i As Integer
For i = 0 To txtKQ.Count - 1
With txtKQ(i)
ChangeBackColor txtKQ(i), isEdit
Select Case i
'Case mtxtName, mtxtSex, mtxtAge, mtxtTitle, mtxtDept, mtxtSDate, mtxtEDate
Case mtxtWorkNo, mtxtSHour, mtxtSMinute, mtxtEHour, mtxtEMinute, mtxtAllowMan
.Locked = Not isEdit
Case mtxtReason
If mStatus = gMAINLEAVE Then
.Locked = Not isEdit
End If
End Select
End With
Next
With cboKQ
.Enabled = isEdit
ChangeBackColor cboKQ, isEdit
End With
For i = 0 To picHour.Count - 1
ChangeBackColor picHour(i), isEdit
Next
For i = 0 To picMinite.Count - 1
ChangeBackColor picMinite(i), isEdit
Next
For i = 0 To VScrollHour.Count - 1
VScrollHour(i).Enabled = isEdit
Next
For i = 0 To VScrollMinite.Count - 1
VScrollMinite(i).Enabled = isEdit
Next
If isEdit Then
txtKQ(mtxtWorkNo).SetFocus
End If
End Sub
Private Function getNowTime() As String
getNowTime = Format(Now, "yyyy-mm-dd hh:mm:ss")
End Function
Private Sub IntoMain(Index As Integer)
Select Case Index
Case gMAINCOLLECT
showMainPic True
Case gMAINLEAVE, gMAINABSENT
msfGrid.Visible = False
showMainPic False, Index
With msfGrid
If Index = gMAINLEAVE Then
.Cols = mIntLeaveCols
'.FormatString = mLeaveTitle
ElseIf Index = gMAINABSENT Then
.Cols = mIntAbsentCols
'.FormatString = mAbsentTitle
End If
iniGridRows msfGrid
End With
msfGrid.Visible = True
End Select
End Sub
Private Sub iniGridRows(myGrid As MSFlexGrid)
With myGrid
.Rows = .FixedRows 'clear old data
.Rows = gFIXEDROWS
End With
'RefreshHistory
End Sub
Private Sub RefreshHistory()
'If (mStatus <> gMAINLEAVE) And (mStatus <> gMAINABSENT) Then Exit Sub
Dim Rst As Recordset
Dim Sql As String
Sql = "Select * from "
If mStatus = gMAINLEAVE Then
Sql = Sql & "QryLeave"
ElseIf mStatus = gMAINABSENT Then
Sql = Sql & "QryAbsent"
ElseIf mStatus = gMAINCOLLECT Then
Sql = Sql & "QryKqHistory"
End If
Sql = Sql & " where left(trim(OperateTime),10)='" & _
Format(Now, "yyyy-mm-dd") & "' order by WorkNo"
Set Rst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot)
Dim Str As String
With Rst
While Not .EOF
Str = Str & IIf(IsNull(!WorkNo), "", Trim(!WorkNo)) _
& vbTab & IIf(IsNull(!Name), "", Trim(!Name)) _
& vbTab & IIf(IsNull(!Sex), "", Trim(!Sex)) _
& vbTab & IIf(IsNull(!DeptName), "", Trim(!DeptName)) _
& vbTab & IIf(IsNull(!TitleName), "", Trim(!TitleName))
If mStatus = gMAINCOLLECT Then
Str = Str & vbTab & IIf(IsNull(!KqDate), "", Trim(!KqDate)) _
& vbTab & IIf(IsNull(!KqTime), "", Trim(!KqTime))
Else
Str = Str & vbTab & IIf(IsNull(!StartDate), "", Trim(!StartDate)) _
& vbTab & IIf(IsNull(!StartTime), "", Trim(!StartTime)) _
& vbTab & IIf(IsNull(!EndDate), "", Trim(!EndDate)) _
& vbTab & IIf(IsNull(!EndTime), "", Trim(!EndTime)) & vbTab
If mStatus = gMAINLEAVE Then
Str = Str & IIf(IsNull(!TypeName), "", Trim(!TypeName)) _
& vbTab & IIf(IsNull(!AllowMan), "", Trim(!AllowMan)) _
& vbTab & IIf(IsNull(!Reason), "", Trim(!Reason))
ElseIf mStatus = gMAINABSENT Then
Dim tmpMyStr As String
If Not IsNull(!isEvection) Then
If !isEvection Then
tmpMyStr = GSHIFTEVECTIONSTR
Else
tmpMyStr = GSHIFTMONEYSTR
End If
Else
tmpMyStr = Empty
End If
Str = Str & tmpMyStr & vbTab _
& IIf(IsNull(!AllowMan), "", Trim(!AllowMan))
End If
End If
If Not .EOF Then
Str = Str & vbCr
End If
.MoveNext
Wend
End With
Dim intCols As Integer
Dim intRows As Integer
intRows = Rst.RecordCount + msfGrid.FixedRows
If mStatus = gMAINLEAVE Then
intCols = mIntLeaveCols
ElseIf mStatus = gMAINABSENT Then
intCols = mIntAbsentCols
ElseIf mStatus = gMAINCOLLECT Then
intCols = mIntCollectCols
End If
ClipToGrid msfGrid, Str, intRows, intCols
Rst.Close
Set Rst = Nothing
End Sub
Private Sub showMainPic(isTrue As Boolean, Optional MainStatus As Integer = gMAINCOLLECT)
picMain.Visible = isTrue
picEdit.Visible = Not isTrue
fraEdit.Visible = Not isTrue
With msfGrid
If isTrue Then
If UBound(mColNotRegister) > 0 _
Or UBound(mColInValidCard) > 0 Then
fraList.Visible = True
.Top = mHasInValidTop
.Height = mHasInValidHeight
Else
.Top = mValidTop
.Height = mValidHeight
End If
Else
If fraList.Visible Then fraList.Visible = False
If MainStatus = gMAINABSENT Then
txtKQ(mtxtReason).Visible = False
fraEdit.Height = 2235 - 495
.Top = 2670
.Height = 5175
Else
txtKQ(mtxtReason).Visible = True
fraEdit.Height = 2235
.Top = mHasInValidTop
.Height = mHasInValidHeight
End If
End If
End With
Dim tmpStr As String
tmpStr = "类别"
If MainStatus = gMAINLEAVE Or MainStatus = gMAINABSENT Then
If MainStatus = gMAINLEAVE Then
tmpStr = GSHIFTLEAVESTR & tmpStr
FillCbo cboKQ, aLeaveType
If Not txtKQ(mtxtReason).Visible Then
txtKQ(mtxtReason).Visible = True
lblReason.Visible = True
End If
Else
cboKQ.Clear
tmpStr = mstrAbsent & tmpStr
With cboKQ
.AddItem GSHIFTEVECTIONSTR
.ItemData(.NewIndex) = -1
.AddItem GSHIFTMONEYSTR
.ItemData(.NewIndex) = 0
.ListIndex = 0
End With
If txtKQ(mtxtReason).Visible Then
txtKQ(mtxtReason).Visible = False
lblReason.Visible = False
End If
End If
Label1(9).Caption = tmpStr
'txtKQ(mtxtworkno).SetFocus
End If
mStatus = MainStatus
End Sub
Private Sub cmdKq_Click(Index As Integer)
Select Case Index
Case mCollect
Dim Fr As frmSelPos
Dim isOK As Boolean
Set Fr = New frmSelPos
Fr.Show 1
isOK = Fr.mIsOk
mPosName = Fr.mPosName
Unload Fr
Set Fr = Nothing
If Not isOK Then Exit Sub
If CollectDataFromPos Then
WriteTempToKq
End If
Case mRefresh
RefreshHistory
Case gCMDAPPEND
mblnCollectModify = False
cmdKq(gCMDAPPEND).Enabled = False
AppendToGrid
cmdKq(gCMDSAVE).Enabled = True
Case gCMDSAVE
SaveCollect
Case gCMDEDIT
Case gCMDDELETE
DeleteCollect
Case gCMDQUERY
Case gCMDRETURN
Unload Me
End Select
End Sub
Private Sub DeleteCollect()
Dim strWorkNo As String
Dim strKqDate As String
Dim strKqTime As String
Dim Sql As String
On Error GoTo DeleteErr
With msfGrid
strWorkNo = Trim(.TextMatrix(.row, mGridWorkNo))
strKqDate = Trim(.TextMatrix(.row, mGridStartDate))
strKqTime = Trim(.TextMatrix(.row, mGridStartTime))
Sql = "update KqHistory set " _
& " F_DelFlag=" & gTRUE _
& " where WorkNo='" & strWorkNo & "' " _
& " and KqDate='" & strKqDate & "' " _
& " and KqTime='" & strKqTime & "'"
gDataBase.Execute Sql
End With
With msfGrid
If .Rows = .FixedRows + 1 Then
.Rows = .FixedRows
Else
.RemoveItem .row
End If
End With
Exit Sub
DeleteErr:
MsgBox "抱歉,删除不成功" & vbCrLf & Err.Description, vbInformation, gTitle
Err.Clear
End Sub
Private Sub AppendToGrid()
With msfGrid
.Rows = .Rows + 1
.row = .Rows - 1
.col = mGridWorkNo
SetTxtPosition msfGrid, txtEdit
End With
End Sub
Private Sub Form_Load()
SetFormPosition
ReDim mColNotRegister(0)
mColNotRegister(0).WorkNo = ""
ReDim mColInValidCard(0)
mColInValidCard(0).WorkNo = ""
iniTitle
SetGridColor msfGrid
If mMenuIndex = gMAINCOLLECT Then
lstNotRegister.BackColor = gGridBackColor
lstInValidCard.BackColor = gGridBackColor
RefreshButton cmdKq, gCMDEDITNORMAL
Else
ChangeColorFortxtKQ False
InitxtEdit 'inidate
RefreshButton cmdEdit, gCMDEDITNORMAL
End If
IntoMain mMenuIndex
msfGrid.FormatString = mFormatString ' 'mAbsentTitle 'mLeaveTitle
End Sub
Private Sub SetFormPosition()
Me.Left = (12000 - Me.Width) / 2
Me.Top = (9000 - Me.Height)
End Sub
Private Function getToday() As String
getToday = Format(Now, "yyyy-mm-dd")
End Function
'Private Sub setStatusBar(Index As Integer, MsgStr As String)
' sbrData.Panels(Index).Text = MsgStr
'End Sub
Private Sub lstNotRegister_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
With lstNotRegister
If .ListCount <= 0 Then Exit Sub
If Button = 2 Then
'RefreshCard mnuEditCard, Val(.TextMatrix(.row, .Cols - 1))
'Refresh
Dim strWorkNo As String
strWorkNo = Left(Trim(.Text), 4)
RefreshmnuList strWorkNo
PopupMenu mnuList
End If
End With
End Sub
Private Sub RefreshmnuList(strWorkNo As String)
Dim Rst As Recordset
Dim blnIsRegister As Boolean
Set Rst = gDataBase.OpenRecordset("select * from Employee" _
& " where WorkNo='" & Trim(strWorkNo) _
& "' order by WorkNo", dbOpenSnapshot)
blnIsRegister = Rst.RecordCount <= 0
Rst.Close
Set Rst = Nothing
mnuListAppend.Enabled = Not blnIsRegister
mnuListRegister.Enabled = blnIsRegister
End Sub
Private Sub mnuListAppend_Click()
If Trim(lstNotRegister.Text) = Empty Then Exit Sub
If MsgBox("是否要把此条记录添加到考勤数据采集中?", _
vbQuestion + vbYesNo, gTitle) = vbNo Then Exit Sub
Dim strWorkNo As String
Dim strKqDate As String
Dim strKqTime As String
Dim intTemp As Integer
Dim strList As String
Dim intListIndex As Integer
intListIndex = lstNotRegister.ListIndex
strList = Trim(lstNotRegister.Text)
strWorkNo = Left(strList, 4)
strList = Trim(Mid(strList, 5))
intTemp = InStr(1, strList, " ", vbTextCompare)
strKqDate = Trim(Left(strList, intTemp))
strKqTime = Trim(Mid(strList, intTemp))
Dim Rst As Recordset
Dim EmpRst As Recordset
Dim strIn As String
On Error GoTo ErrHandle
Set Rst = gDataBase.OpenRecordset("KqHistory")
Set EmpRst = gDataBase.OpenRecordset("Select * from " _
& " QryEmployee where WorkNo='" & strWorkNo & "'" & _
" order by WorkNo", dbOpenSnapshot)
If EmpRst.RecordCount > 0 Then
Rst.AddNew
Rst!WorkNo = strWorkNo
Rst!KqDate = strKqDate
Rst!KqTime = strKqTime
Rst.Update
With EmpRst
strIn = strWorkNo & vbTab _
& !Name & vbTab & !Sex & vbTab _
& !DeptName & vbTab & !TitleName & vbTab _
& strKqDate & vbTab & strKqTime
End With
msfGrid.AddItem strIn
lstNotRegister.RemoveItem intListIndex
End If
Rst.Close
Set Rst = Nothing
EmpRst.Close
Set EmpRst = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Description, vbInformation, gTitle
Err.Clear
Exit Sub
'End If
End Sub
Private Sub mnuListRegister_Click()
If lstNotRegister.ListCount <= 0 Then Exit Sub
If MsgBox("是否要对此卡进行登记?", _
vbQuestion + vbYesNo, gTitle) = vbNo Then Exit Sub
With frmEmploy
.Show 0, Me
.cmdEdit_Click 0
.txtEmp(0) = Left(Trim(lstNotRegister.Text), 4)
End With
End Sub
Private Sub mSetColor_Click()
End Sub
Private Sub mSetOption_Click()
End Sub
Private Sub medDate_GotFocus()
msfGrid.Enabled = False
medDate.SelStart = 0
medDate.SelLength = Len(medDate.Text)
End Sub
Private Sub medDate_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyReturn
Dim Str As String
Str = Trim(medDate.Text)
With msfGrid
If Str <> Empty Then
.TextMatrix(.row, mGridStartDate) = Str
medDate.Visible = False
If Not mblnCollectModify Then
.col = mGridStartTime
SetMedPosition msfGrid, medTime, False
Else
If Str <> mOldKqDate Then
If SaveCollectByModify Then
mblnCollectModify = False
Else
.TextMatrix(.row, mGridStartDate) = mOldKqDate
End If
End If
msfGrid.Enabled = True
End If
End If
End With
Case vbKeyEscape
If mblnCollectModify Then
If medDate.Visible Then medDate.Visible = False
If Not msfGrid.Enabled Then msfGrid.Enabled = True
msfGrid.SetFocus
End If
End Select
End Sub
Private Function SaveCollectByModify() As Boolean
Dim strWorkNo As String
Dim strKqDate As String
Dim strKqTime As String
Dim Sql As String
On Error GoTo SaveErr
With msfGrid
strWorkNo = Trim(.TextMatrix(.row, mGridWorkNo))
strKqDate = Trim(.TextMatrix(.row, mGridStartDate))
strKqTime = Trim(.TextMatrix(.row, mGridStartTime))
Sql = "update KqHistory set " _
& " KqDate='" & strKqDate & "'," _
& " KqTime='" & strKqTime & "' " _
& " where WorkNo='" & strWorkNo & "' " _
& " and KqDate='" & mOldKqDate & "' " _
& " and KqTime='" & mOldKqTime & "'"
gDataBase.Execute Sql
End With
SaveCollectByModify = True
Exit Function
SaveErr:
MsgBox "抱歉,保存不成功" & vbCrLf & Err.Description, vbInformation, gTitle
Err.Clear
SaveCollectByModify = False
End Function
Private Sub medDate_LostFocus()
medDate.Visible = False
End Sub
Private Sub medTime_GotFocus()
msfGrid.Enabled = False
medTime.SelStart = 0
medTime.SelLength = Len(medTime.Text)
End Sub
Private Sub medTime_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyReturn
Dim Str As String
Str = Trim(medTime.Text)
With msfGrid
If Str <> Empty Then
.TextMatrix(.row, mGridStartTime) = Str
medTime.Visible = False
If Not mblnCollectModify Then
cmdKq_Click gCMDSAVE
Else
If Str <> mOldKqTime Then
If SaveCollectByModify Then
mblnCollectModify = False
Else
.TextMatrix(.row, mGridStartTime) = mOldKqTime
End If
End If
msfGrid.Enabled = True
End If
End If
End With
Case vbKeyEscape
If mblnCollectModify Then
If medTime.Visible Then medTime.Visible = False
If Not msfGrid.Enabled Then msfGrid.Enabled = True
msfGrid.SetFocus
End If
End Select
End Sub
Private Sub SaveCollect()
Dim strWorkNo As String
Dim strKqDate As String
Dim strKqTime As String
With msfGrid
strWorkNo = Trim(.TextMatrix(mRowBeforeSave, mGridWorkNo))
strKqDate = Trim(.TextMatrix(mRowBeforeSave, mGridStartDate))
strKqTime = Trim(.TextMatrix(mRowBeforeSave, mGridStartTime))
If strKqDate = Empty Then
MsgBox "考勤日期不能为空,请输入!!", vbInformation, gTitle
.col = mGridStartDate
SetMedPosition msfGrid, medDate, True
Exit Sub
End If
If strKqTime = Empty Then
MsgBox "考勤时间不能为空,请输入!!", vbInformation, gTitle
.col = mGridStartTime
SetMedPosition msfGrid, medTime, False
Exit Sub
End If
On Error GoTo SaveErr
Dim Sql As String
Sql = "Insert into KqHistory (WorkNo,KqDate,KqTime,OperateTime) values('" _
& strWorkNo & "','" & strKqDate & "','" _
& strKqTime & "','" & Format(Date, "yyyy-mm-dd") & "')"
gDataBase.Execute Sql
msfGrid.Enabled = True
cmdKq(gCMDAPPEND).Enabled = True
cmdKq(gCMDSAVE).Enabled = False
End With
Exit Sub
SaveErr:
MsgBox "保存未成功" & vbCrLf & Err.Description, vbExclamation, gTitle
Err.Clear
End Sub
Private Sub medTime_LostFocus()
medTime.Visible = False
End Sub
Private Sub mnuEditDelete_Click()
cmdEdit_Click gCMDDELETE
End Sub
Private Sub mnuEditModify_Click()
cmdEdit_Click gCMDEDIT
End Sub
Private Sub msfGrid_DblClick()
If mStatus = gMAINCOLLECT Then
With msfGrid
Select Case .col
Case mGridStartDate, mGridStartTime
mblnCollectModify = True
mOldKqDate = Trim(.TextMatrix(.row, mGridStartDate))
mOldKqTime = Trim(.TextMatrix(.row, mGridStartTime))
If .col = mGridStartDate Then
.col = mGridStartDate
SetMedPosition msfGrid, medDate, True
With medDate
.Mask = ""
.Text = mOldKqDate
.Mask = mDATEMASK
End With
Else
.col = mGridStartTime
SetMedPosition msfGrid, medTime, False
With medTime
.Mask = ""
.Text = mOldKqTime
.Mask = mTIMEMASK
End With
End If
End Select
End With
End If
End Sub
Private Sub msfGrid_GotFocus()
If msfGrid.Rows <= msfGrid.FixedRows Then Exit Sub
If mStatus = gMAINCOLLECT Then
cmdKq(gCMDEDIT).Enabled = True
cmdKq(gCMDDELETE).Enabled = True
Else
If Not (mblnIsModify Or mblnIsAdd) Then
RefreshBtnLocal True
End If
End If
End Sub
Private Sub RefreshBtnLocal(blnIsGotFocus As Boolean)
cmdEdit(gCMDEDIT).Enabled = blnIsGotFocus
cmdEdit(gCMDDELETE).Enabled = blnIsGotFocus
End Sub
'Private Sub mnuPosDateSet_Click()
' frmSetDate.Show 1
'End Sub
'Private Sub mnuQueryFlow_Click()
' frmFlow.Show 0, Me
'End Sub
Private Sub msfGrid_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
If mStatus = gMAINCOLLECT Then
msfGrid_DblClick
End If
End If
End Sub
'Private Sub Timer1_Timer()
' sbrData.Panels(4).Text = "时间:" & Format(Now, "hh:mm:ss")
'End Sub
Private Sub iniTitle()
Dim strTemp As String
Select Case mMenuIndex
Case gMAINCOLLECT
strTemp = "^工 号" & Space(3) & vbTab _
& "<姓 名" & Space(5) & vbTab _
& "^性 别" & Space(5) & vbTab _
& "<部 门" & Space(7) & vbTab _
& "<职 务" & Space(7) & vbTab _
& "^考 勤 日 期" & Space(11) & vbTab _
& "^考 勤 时 间" & Space(11) '7
Case gMAINLEAVE
strTemp = "^工 号" & Space(0) & vbTab _
& "<姓 名" & Space(2) & vbTab _
& "^性 别" & Space(0) & vbTab _
& "<部 门" & Space(1) & vbTab _
& "<职 务" & Space(1) & vbTab _
& "^起始日期" & Space(3) & vbTab _
& "^起始时间" & Space(1) & vbTab _
& "^截止日期" & Space(3) & vbTab _
& "^截止时间" & Space(1) & vbTab _
& "<请假类型" & Space(0) & vbTab _
& "<批准人" & Space(2) & vbTab _
& "<事 由" & Space(5) '12
Case gMAINABSENT
strTemp = "^工 号" & Space(1) & vbTab _
& "<姓 名" & Space(2) & vbTab _
& "^性 别" & Space(1) & vbTab _
& "<部 门" & Space(2) & vbTab _
& "<职 务" & Space(2) & vbTab _
& "^起始日期" & Space(4) & vbTab _
& "^起始时间" & Space(3) & vbTab _
& "^截止日期" & Space(4) & vbTab _
& "^截止时间" & Space(3) & vbTab _
& "<缺席类型" & Space(2) & vbTab _
& "<批准人" & Space(2) '11
End Select
mFormatString = strTemp
End Sub
Private Sub msfGrid_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
With msfGrid
If .MouseRow = 0 Then Exit Sub
If .Rows <= .FixedRows Then Exit Sub
If Button = 2 Then
If Trim(.TextMatrix(.MouseRow, mGridWorkNo)) <> Empty Then
PopupMenu mnuEdit
End If
End If
End With
End Sub
Private Sub txtEdit_GotFocus()
msfGrid.Enabled = False
mRowBeforeSave = msfGrid.row
GotFocus txtEdit
End Sub
Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case 13
Dim Str As String
Dim strName As String
Dim strSex As String
Dim strDept As String
Dim strTitle As String
Dim Sql As String
Dim Rst As Recordset
Str = Trim(txtEdit)
Sql = " select * from QryEmployee where WorkNo='" & Str & "'" _
& " order by WorkNo"
Set Rst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot)
If Rst.RecordCount > 0 Then
strName = IIf(IsNull(Rst!Name), "", Trim(Rst!Name))
strSex = IIf(IsNull(Rst!Sex), "", Trim(Rst!Sex))
strDept = IIf(IsNull(Rst!DeptName), "", Trim(Rst!DeptName))
strTitle = IIf(IsNull(Rst!TitleName), "", Trim(Rst!TitleName))
txtEdit.Visible = False
With msfGrid
.TextMatrix(.row, mGridWorkNo) = Str
.TextMatrix(.row, mGridName) = strName
.TextMatrix(.row, mGridSex) = strSex
.TextMatrix(.row, mGridDept) = strDept
.TextMatrix(.row, mGridTitle) = strTitle
.col = mGridStartDate
End With
SetMedPosition msfGrid, medDate, True
End If
Case 27
txtEdit_LostFocus
End Select
End Sub
Private Sub SetMedPosition(tmpGrid As MSFlexGrid, tmpMed As MaskEdBox, Optional isDate As Boolean = True)
With tmpGrid
tmpMed.Top = .Top + .CellTop
tmpMed.Left = .Left + .CellLeft
tmpMed.Width = .CellWidth
tmpMed.Height = .CellHeight
tmpMed.Mask = ""
'tmpMed.Text = ""
If isDate Then
tmpMed.Text = Format(Date, "yyyy-mm-dd")
tmpMed.Mask = mDATEMASK
Else
tmpMed.Text = "08:00"
tmpMed.Mask = mTIMEMASK
End If
tmpMed.Visible = True
tmpMed.SetFocus
End With
End Sub
Private Sub txtEdit_LostFocus()
txtEdit.Visible = False
ValidAction msfGrid, txtEdit
End Sub
Private Sub ValidAction(tmpGrid As MSFlexGrid, tmpTxt As TextBox)
With tmpGrid
If Trim(.TextMatrix(.row, mGridWorkNo)) = Empty Then
.Rows = .Rows - 1
cmdKq(gCMDAPPEND).Enabled = True
cmdKq(gCMDSAVE).Enabled = False
msfGrid.Enabled = True
End If
End With
End Sub
Private Sub UpDownCheck(KeyCode As Integer, msfGrid As MSFlexGrid)
Dim sRow, SCol As Integer
With msfGrid
If KeyCode = vbKeyDown Then
sRow = .row + 1
If sRow = .Rows Then
sRow = .FixedRows
End If
ElseIf KeyCode = vbKeyUp Then
sRow = .row - 1
If sRow = 0 Then
sRow = .Rows - 1
End If
ElseIf KeyCode = 13 Then
sRow = .row
End If
SCol = .ColSel
.row = sRow
.col = SCol
.RowSel = sRow
End With
End Sub
Private Sub FillGridByRst(myGrid As MSFlexGrid, CurRow As Integer, Rst As Recordset)
With myGrid
.TextMatrix(CurRow, 1) = IIf(IsNull(Rst!Name), "", Trim(Rst!Name))
.TextMatrix(CurRow, 2) = IIf(IsNull(Rst!Sex), "", Trim(Rst!Sex))
'.TextMatrix(CurRow, 3) = IIf(IsNull(Rst!Age), "", Trim(Rst!Age))
.TextMatrix(CurRow, 3) = IIf(IsNull(Rst!Department), "", Trim(Rst!Deptment))
.TextMatrix(CurRow, 4) = IIf(IsNull(Rst!Title), "", Trim(Rst!Title))
End With
End Sub
Private Sub txtKQ_Change(Index As Integer)
If Index = mtxtWorkNo Then
If Not txtKQ(Index).Locked Then
mblnIsNeedSave = Trim(txtKQ(Index)) <> Empty
End If
End If
End Sub
Private Sub txtKQ_DblClick(Index As Integer)
' If Not mdblClickIsValid Then Exit Sub
Select Case Index
Case mtxtWorkNo, mtxtSDate, mtxtEDate
txtKQ_KeyDown Index, 13, vbCtrlMask
End Select
End Sub
Private Sub txtKQ_GotFocus(Index As Integer)
GotFocus txtKQ(Index)
End Sub
Private Sub txtKQ_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
Select Case Index
Case mtxtWorkNo, mtxtSDate, mtxtEDate
Dim CtrlDown As Boolean
CtrlDown = (vbCtrlMask And Shift) > 0
If CtrlDown Then
Select Case Index
Case mtxtWorkNo
'frmLookMan.Tag = UCase("frmMain")
With frmLookMan
.Show vbModal
txtKQ(mtxtWorkNo) = .mWorkNo
txtKQ(mtxtName) = .mName
txtKQ(mtxtSex) = .mSex
txtKQ(mtxtAge) = .mAge
txtKQ(mtxtDept) = .mDept
txtKQ(mtxtTitle) = .mTitle
End With
Case mtxtSDate, mtxtEDate
'mRetDate = Empty
'frmRiLi.Tag = UCase("frmMain")
frmRiLi.Show vbModal
If frmRiLi.mRetDate <> Empty Then
txtKQ(Index) = frmRiLi.mRetDate
End If
End Select
Else
SendKeyTab KeyCode
End If
' Case mtxtSHour, mtxtEHour
Case Else
SendKeyTab KeyCode
End Select
End If
End Sub
Private Sub txtKQ_LostFocus(Index As Integer)
Select Case Index
Case mtxtWorkNo
If Trim(txtKQ(mtxtWorkNo)) = Empty Then Exit Sub
If Trim(txtKQ(mtxtName)) <> Empty Then Exit Sub
Dim tmpStr As String
Dim Rst As Recordset
tmpStr = Trim(txtKQ(Index))
Set Rst = gDataBase.OpenRecordset("select * from QryEmployee" _
& " Where WorkNo='" & tmpStr & "'", dbOpenSnapshot)
If Rst.RecordCount > 0 Then
With Rst
txtKQ(mtxtName) = IIf(IsNull(!Name), "", Trim(!Name))
txtKQ(mtxtSex) = IIf(IsNull(!Sex), "", Trim(!Sex))
txtKQ(mtxtAge) = IIf(IsNull(!Age), "", Trim(!Age))
txtKQ(mtxtDept) = IIf(IsNull(!DeptName), "", Trim(!DeptName))
txtKQ(mtxtTitle) = IIf(IsNull(!TitleName), "", Trim(!TitleName))
End With
Else
If Me.Enabled Then
MsgBox "无此工号!请重输!!", , gTitle
txtKQ(mtxtWorkNo).SetFocus
End If
End If
Rst.Close
Set Rst = Nothing
'End If
End Select
End Sub
Private Sub InitxtEdit()
Dim i As Integer
For i = 0 To txtKQ.Count - 1
With txtKQ(i)
Select Case i
Case mtxtSDate, mtxtEDate
.Text = getToday
Case mtxtSHour
.Text = mstrSHour
Case mtxtEHour
.Text = mstrEHour
Case mtxtSMinute, mtxtEMinute
.Text = mstrMinute
Case Else
.Text = Empty
End Select
End With
Next
If cboKQ.ListCount > 0 Then cboKQ.ListIndex = 0
End Sub
Private Function CollectDataFromPos() As Boolean
Dim blnIsOpen As Boolean
Dim blnIsTras As Boolean
'Dim strIn As String
Dim nRecCount As Integer
'Dim Rst As Recordset
Dim nRet As Integer
Dim j As Integer
Dim i As Integer
Dim blnProgIsShow As Boolean
'Set Rst = gDataBase.OpenRecordset("KqHistory")
If OpenComm(gCommPort) <> 0 Then
MsgBox mstrOpenCommErr, vbInformation, gTitle
GoTo CollectErr
End If
blnIsOpen = True
nRecCount = POS_IsReady(gPosNumber)
If nRecCount < 0 Then
MsgBox mMsg1, vbInformation + vbOKOnly, gTitle
GoTo CollectErr
End If
Dim strFrame As String * 20
Dim blnIsAdd As Boolean
Dim strWorkNo As String
Dim strDate As String
Dim strTime As String
'Dim EmpRst As String
On Error GoTo CollectErr
ReDim mKqRecord(0)
mKqRecord(0).WorkNo = ""
'Set Rst = gDataBase.OpenRecordset("KqTemp")
' Set EmpRst = gDataBase.OpenRecordset("select * from " _
' & " QryEmployee order by WorkNo", dbOpenSnapshot)
If nRecCount = 0 Then
If blnIsOpen Then CloseComm
MsgBox mMsg4, vbInformation, gTitle
CollectDataFromPos = False
Exit Function
End If
ReDim Preserve mKqRecord(nRecCount)
Screen.MousePointer = 11
frmMain.Enabled = False
With frmProg
.Label1.Caption = "正在采集[" & mPosName _
& "]的数据,请稍候..."
.Show
.Refresh
End With
blnProgIsShow = True
frmProg.ProgressBar1.Min = 0
If nRecCount > 0 Then
frmProg.ProgressBar1.Max = nRecCount + 1
Else
frmProg.ProgressBar1.Max = 100
End If
BeginTrans
blnIsTras = True
For i = 1 To nRecCount + 1
blnIsAdd = False
nRet = POS_GetNextFrame(gPosNumber, strFrame)
frmProg.ProgressBar1.Value = i
Select Case nRet
Case 0
blnIsAdd = True
Case 1
blnIsAdd = False
Exit For
Case Else
For j = 1 To mRetryTimes
nRet = POS_GetFrameAgain(1, strFrame)
If nRet = 0 Then
blnIsAdd = True
Exit For
End If
Next
If Not blnIsAdd Then
MsgBox mMsg2, vbExclamation + vbOKOnly, gTitle
GoTo CollectErr
End If
End Select
If blnIsAdd Then
If Trim(strFrame) <> Empty Then
strWorkNo = Chr(Val(Mid(strFrame, 1, 1)) * 16 _
+ Val(Mid(strFrame, 2, 1))) & _
Chr(Val(Mid(strFrame, 3, 1)) * 16 _
+ Val(Mid(strFrame, 4, 1))) & _
Chr(Val(Mid(strFrame, 5, 1)) * 16 _
+ Val(Mid(strFrame, 6, 1))) & _
Chr(Val(Mid(strFrame, 7, 1)) * 16 _
+ Val(Mid(strFrame, 8, 1)))
strDate = "20" & Mid(strFrame, 9, 2) & "-" & _
Mid(strFrame, 11, 2) & "-" & _
Mid(strFrame, 13, 2)
strTime = Mid(strFrame, 15, 2) & ":" & _
Mid(strFrame, 17, 2) & ":" & _
Mid(strFrame, 19, 2)
'strIn = strIn & strWorkNo
' Rst.AddNew
' Rst!WorkNo = Trim(strWorkNo)
' Rst!KqDate = Trim(strDate)
' Rst!KqTime = Trim(strTime)
' Rst.Update
With mKqRecord(i)
.WorkNo = Trim(strWorkNo)
.KqDate = Trim(strDate)
.KqTime = Trim(strTime)
End With
Else
MsgBox mMsg3, vbExclamation, gTitle
GoTo CollectErr
End If
End If
Next
CommitTrans
CloseComm
If Not Me.Enabled Then Me.Enabled = True
Screen.MousePointer = 99
Unload frmProg
MsgBox mMsg5, vbInformation, gTitle
CollectDataFromPos = True
Exit Function
CollectErr:
If blnProgIsShow Then
If Not Me.Enabled Then Me.Enabled = True
Screen.MousePointer = 99
If Not frmProg Is Nothing Then Unload frmProg
End If
If blnIsOpen Then
CloseComm
End If
If blnIsTras Then
Rollback
End If
CollectDataFromPos = False
Exit Function
End Function
Private Sub WriteTempToKq()
If UBound(mKqRecord) < 1 Then Exit Sub
Dim i As Integer
Dim strWorkNo As String
Dim strKqDate As String
Dim strKqTime As String
Dim intCardStatus As Integer
Dim strIn As String
Dim Rst As Recordset
Dim EmpRst As Recordset
'Set mColNotRegister = New Collection
'Set mColInValidCard = New Collection
ReDim mColNotRegister(0)
mColNotRegister(0).WorkNo = ""
ReDim mColInValidCard(0)
mColInValidCard(0).WorkNo = ""
Set Rst = gDataBase.OpenRecordset("KqHistory")
Set EmpRst = gDataBase.OpenRecordset("Select * from " _
& " QryEmployee order by WorkNo", dbOpenSnapshot)
' On Error GoTo WriteErr
' Dim blnIsTrans As Boolean
' BeginTrans
' blnIsTrans = True
Dim intRows As Integer
Dim intCols As Integer
For i = 1 To UBound(mKqRecord)
With mKqRecord(i)
strWorkNo = Trim(.WorkNo)
strKqDate = Trim(.KqDate)
strKqTime = Trim(.KqTime)
End With
EmpRst.FindFirst "WorkNo='" & strWorkNo & "'"
If EmpRst.NoMatch Then '卡未登记
ReDim Preserve mColNotRegister(UBound(mColNotRegister) + 1)
With mColNotRegister(UBound(mColNotRegister))
.WorkNo = strWorkNo
.KqDate = strKqDate
.KqTime = strKqTime
End With
Else
If EmpRst!CardStatus <> gHasCard Then '非法卡在流通
ReDim Preserve mColInValidCard(UBound(mColInValidCard) + 1)
With mColInValidCard(UBound(mColInValidCard))
.WorkNo = strWorkNo
.KqDate = strKqDate
.KqTime = strKqTime
End With
Else
Rst.AddNew
Rst!WorkNo = strWorkNo
Rst!KqDate = strKqDate
Rst!KqTime = strKqTime
Rst!OperateTime = Format(Date, "yyyy-mm-dd")
Rst.Update
intRows = intRows + 1
With EmpRst
strIn = strIn & strWorkNo & vbTab _
& !Name & vbTab & !Sex & vbTab _
& !DeptName & vbTab & !TitleName & vbTab _
& strKqDate & vbTab & strKqTime
If i <> UBound(mKqRecord) Then strIn = strIn & vbCr
End With
End If
End If
Next
EmpRst.Close
Set EmpRst = Nothing
Rst.Close
Set Rst = Nothing
If UBound(mColNotRegister) > 0 Or UBound(mColInValidCard) > 0 Then
msfGrid.Top = mHasInValidTop
msfGrid.Height = mHasInValidHeight
If Not fraList.Visible Then
fraList.Visible = True
Dim j As Integer
lstNotRegister.Clear
lstInValidCard.Clear
If UBound(mColNotRegister) > 0 Then
For j = 1 To UBound(mColNotRegister)
With mColNotRegister(j)
lstNotRegister.AddItem FixedLen(.WorkNo, 12, 0) & _
FixedLen(.KqDate, 20, 0) & FixedLen(.KqTime, 16, 0)
End With
Next
End If
If UBound(mColInValidCard) > 0 Then
For j = 1 To UBound(mColInValidCard)
With mColInValidCard(j)
lstInValidCard.AddItem FixedLen(.WorkNo, 12, 0) & _
FixedLen(.KqDate, 20, 0) & FixedLen(.KqTime, 16, 0)
End With
Next
End If
lblNotRegister = UBound(mColNotRegister)
lblInvalidCard = UBound(mColInValidCard)
End If
Else
If fraList.Visible Then
fraList.Visible = False
msfGrid.Top = mValidTop
msfGrid.Height = mValidHeight
End If
End If
intCols = mIntCollectCols
ClipToGrid msfGrid, strIn, intRows + 1, intCols
'Exit Sub
'WriteErr:
' If blnIsTrans Then
' Rollback
' End If
End Sub