www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > kqModule.bas

Attribute VB_Name = "kqMod" 
Public gDataBase As Database 
Public gTitle As String 
Public gMaxDay  As Integer 
Public Const gMAXITEM = 999 
Public Const gLATETIME = "07:55" 
Public Const gSTRPWD = "wsh2000" 
 
Public gMainDbName As String 
 
Public gLoginGrade As Integer 
Public gLoginName As String 
 
Public gPlanTableName As String 
Public Const gQRY = "Qry" 
Public gPlanQryName As String 
Public Const gRELEMPLOYEEPLAN = "EmployeePlan" 
Public Const gRELSHIFTPLAN = "ShiftPlan" 
Public gRelEmp As String 
Public gRelShift As String 
 
Public gOwnName As String 
Public gOwnAddress As String 
Public gOwnPhone As String 
Public gOwnFax As String 
Public gOwnPost As String 
Public gOwnOwner As String 
 
Public Const GSHIFTRESTID = 1 '休息 
Public Const GSHIFTLEAVEID = 2 '请假 
Public Const GSHIFTEVECTIONID = 3 '出差 
Public Const GSHIFTMONEYID = 4 '有薪假期 
Public Const GSHIFTRESTSTR = "休息" 
Public Const GSHIFTLEAVESTR = "请假" 
Public Const GSHIFTEVECTIONSTR = "出差" 
Public Const GSHIFTMONEYSTR = "有薪假期" 
Public Const GSHIFTRESTNAME = "*" '休息 
Public Const GSHIFTLEAVENAME = "#" '请假 
Public Const GSHIFTEVECTIONNAME = "@" '出差 
Public Const GSHIFTMONEYNAME = "$" '有薪假期 
Public Const gNOSHIFT = 0 
Public Const gNOSHIFTNAME = "未排班" 
Public Const gNOTINWORK = "旷工" 
Public Const gWORKLATE = "迟到" 
Public Const gNORMALKQSTR = "正常出勤" 
 
Public Const gALLDEPTNAME = "所有部门" 
 
Type OwnerShift 
    ID As Integer 
    ShiftName As String 
    Note As String 
End Type 
 
Public aInnerShift(1 To 4) As OwnerShift 
 
 
Type KQTemp 
    WorkNo As String 
    KqDate As String 
    KqTime As String 
End Type 
 
'----card status 
Public Const gNoCard = 0 
Public Const gHasCard = 1 
Public Const gMissCard = 2 
 
Public gPosNumber  As Integer 
Public gCommPort As Integer 
 
Public Type ItemStruc 
    ID As Integer 
    Name As String 
End Type 
 
Public Const mstrOpenCommErr = "无法打开串口!" 
 
Global aDepartment() As ItemStruc 
Global aTitle() As ItemStruc 
Global aLeaveType() As ItemStruc 
 
'*****编辑按钮索引 
Public Const gCMDAPPEND = 0 
Public Const gCMDSAVE = 1 
Public Const gCMDEDIT = 2 
Public Const gCMDDELETE = 3 
Public Const gCMDQUERY = 4 
Public Const gCMDRETURN = 5 
'Private Const mRefresh = 6 
Public Const gCMDEDITNORMAL = 7 '正常的cmdEdit的状态 
Public Const gCMDEDITCANCEL = 8 '取消添加后刷新按钮 
'*****编辑按钮动态更新字串 
Public Const gSTRAPPEND = "添加" 
Public Const gSTRCANCEL = "取消" 
Public Const gSTRMODIFY = "修改" 
Public Const gSTRRESET = "还原" 
 
Global gUserID As String 
Const mMsg1 = "班次初始化有误,系统不能正常运行!" 
 
'区分从frmMDI进入frmMain常数 
Public Const gMAINCOLLECT = 0 
Public Const gMAINLEAVE = 1 
Public Const gMAINABSENT = 2 
 
Const modMsg2 = "新的月份已开始,本月是否沿用上月的排班表?" 
Const modMsg3 = "欢迎您进入新月份的排班!" 
Public Const gMsg3 = "该名称已经存在,请您换个名称!!" 
Public Const gMsg4 = "请选择要删除的记录!!" 
Public Const gMsg5 = "抱歉,保存未成功!" 
Public Const gMsg6 = "抱歉,删除未成功!" 
Public Const gMsg7 = "抱歉,添加未成功!" 
Public Const gMsg8 = "数据有改动,要保存吗?" 
Public Const gMsg9 = "恭喜,保存成功!!" 
Public Const gMsg10 = "您确定要删除该条记录吗?" 
Public Const gMsg11 = "请准备好打印机,按[确定]开始打印..." 
Public Const gMsg12 = "抱歉,打印未成功!" 
 
Public Function CreateATable(TableName As String) As Boolean 
    Dim Sql As String 
    Dim strPrevTableName As String 
    Dim strPrevMonth As String 
    Dim strPrevYear As String 
    Dim blnCreateNew As Boolean 
    Dim HasThisTD As Boolean 
     
    On Error GoTo CreateErr 
    HasThisTD = False 
    strPrevYear = Year(Date) 
    strPrevMonth = Month(Date) - 1 
    If Val(strPrevMonth) = 0 Then 
        strPrevYear = Val(strPrevYear) - 1 
        strPrevMonth = 12 
    End If 
    strPrevTableName = Right(strPrevYear, 2) & strPrevMonth 
     
    HasThisTD = HasThisTable(strPrevTableName) 
    blnCreateNew = True 
    If HasThisTD Then 
'        If MsgBox(modMsg2, vbQuestion + vbYesNo, gTitle) = vbYes Then '是否沿用 
'            Sql = "select * into " & TableName & " from " & strPrevTableName 
'            gDataBase.Execute Sql 
'            Sql = "delete * from " & TableName 
'            gDataBase.Execute Sql 
'            blnCreateNew = False 
'        Else 
            MsgBox modMsg3, vbInformation, gTitle 
'        End If 
    End If 
    If blnCreateNew Then 
        Sql = "select * into " & TableName & " from EmptyPlan" 
        gDataBase.Execute Sql 
    End If 
     
    '创建关系 
    Dim Rel As Relation 
    Dim RelName As String 
    Dim HasRel As Boolean 
     
    RelName = gRelShift 
    HasRel = HasThisRelation(RelName) 
     
    If Not HasRel Then 'create relation 
        Set Rel = gDataBase.CreateRelation(RelName) 
        With Rel 
            .Table = "Shift" 
            .ForeignTable = TableName 
            .Fields.Append .CreateField("ID") 
            .Fields("ID").ForeignName = "F_Shift" 
            gDataBase.Relations.Append Rel 
        End With 
    End If 
     
    Set Rel = Nothing 
    HasRel = False 
    RelName = gRelEmp 
    HasRel = HasThisRelation(RelName) 
    If Not HasRel Then 
        Set Rel = gDataBase.CreateRelation(RelName) 
        With Rel 
            .Table = "Employee" 
            .ForeignTable = TableName 
            .Fields.Append .CreateField("WorkNo") 
            .Fields("WorkNo").ForeignName = "WorkNo" 
            gDataBase.Relations.Append Rel 
        End With 
    End If 
    Set Rel = Nothing 
     
'    Dim QD As QueryDef 
    Dim QDName As String 
    Dim HasThisQry As Boolean 
    QDName = gPlanQryName 
    HasThisQry = HasThisQuery(QDName) 
    If Not HasThisQry Then 
        Set QD = New QueryDef 'PARAMETERS DeptID Short; 
        QD.Sql = "select a.Name,a.DeptID," _ 
            & "b.WorkNo," _ 
            & "b.F_Day,c.ShiftName,c.ID" _ 
            & " from Employee a," _ 
            & TableName & " b,Shift c" _ 
            & " where a.WorkNo=b.WorkNo " _ 
            & "and b.F_Shift=c.ID and a.F_DelFlag=" & gFALSE _ 
            & " order by b.WorkNo" 
        QD.Name = QDName 
        gDataBase.QueryDefs.Append QD 
    End If 
    QD.Close 
    Set QD = Nothing 
    CreateATable = True 
    Exit Function 
CreateErr: 
    Err.Clear 
    CreateATable = False 
    Exit Function 
End Function 
 
Public Function HasThisQuery(QryName As String) As Boolean 
    Dim QD As QueryDef 
    For Each QD In gDataBase.QueryDefs 
        If QD.Name = QryName Then 
            HasThisQuery = True 
            Exit Function 
        End If 
    Next 
    HasThisQuery = False 
End Function 
 
Public Function HasThisRelation(RelName As String) As Boolean 
    Dim Rel As Relation 
    For Each Rel In gDataBase.Relations 
        If Rel.Name = RelName Then 
            HasThisRelation = True 
            Exit Function 
        End If 
    Next 
    HasThisRelation = False 
End Function 
 
 
Function AsciiToVal(nAscii As Byte) 
  Select Case UCase(nAscii) 
  Case 48 To 57: AsciiToVal = nAscii - 48 
  Case 65 To 70: AsciiToVal = nAscii - 55 
  Case 97 To 102: AsciiToVal = nAscii - 87 
 End Select 
End Function 
 
Public Sub Main() 
    If App.PrevInstance Then Exit Sub 
    Dim Str As String 
    ChDrive Mid(App.Path, 1, 2) 
    ChDir App.Path 
     
    GetRegister 
    gTitle = "考勤系统" 
    gMaxDay = GetMaxDayInAMonth(Year(Date), Month(Date)) 
    gUserID = "Wsh" 
    Str = App.Path + "\data\kq.mdb" 
    gMainDbName = Str 
    On Error GoTo OpenErr 
    If Dir(Str) <> Empty Then 
        Set gDataBase = Workspaces(0).OpenDatabase(Str, False, False, ";pwd=" & gSTRPWD) 
    Else 
        MsgBox "找不到数据库!请您检查一下您的数据库路径!!", , gTitle 
        End 
    End If 
     
    SetPlanTableName 
     
    IniPort 
    IniItem "Department", aDepartment() 
    IniItem "LeaveType", aLeaveType() 
    IniItem "Title", aTitle() 
    IniShift 
     
    aDepartment(0).Name = gALLDEPTNAME 
    aLeaveType(0).Name = "所有请假类型" 
    aTitle(0).Name = "所有职务" 
     
    'frmSplash.Show 
    'frmMonth.Show 
    'frmLookMan.Show 1 
    'frmEmploy.Show 1 
    'frmPlan.Show 
    Dim Fr As New frmLogin 
    Set Fr = New frmLogin 
    Fr.Show 1 
    If Not Fr.LoginSucceeded Then 
        EndSystem 
    Else 
        frmMDI.Show 
        Unload Fr 
    End If 
    
    Exit Sub 
OpenErr: 
    MsgBox Err.Description, , gTitle 
    Err.Clear 
    EndSystem 
End Sub 
 
Private Sub IniPort() 
    gPosNumber = 1 
    gCommPort = 0 
End Sub 
Public Sub SetPlanTableName() 
    gPlanTableName = Right(Year(Date), 2) & Month(Date) 
    gPlanQryName = gQRY & gPlanTableName 
    gRelEmp = Trim(gPlanTableName) & gRELEMPLOYEEPLAN 
    gRelShift = Trim(gPlanTableName) & gRELSHIFTPLAN 
End Sub 
Private Sub IniShift() 
    With aInnerShift(1) 
        .ID = GSHIFTRESTID 
        .ShiftName = GSHIFTRESTNAME 
        .Note = GSHIFTRESTSTR 
    End With 
     
    With aInnerShift(2) 
        .ID = GSHIFTLEAVEID 
        .ShiftName = GSHIFTLEAVENAME 
        .Note = GSHIFTLEAVESTR 
    End With 
     
    With aInnerShift(3) 
        .ID = GSHIFTEVECTIONID 
        .ShiftName = GSHIFTEVECTIONNAME 
        .Note = GSHIFTEVECTIONSTR 
    End With 
     
    With aInnerShift(4) 
        .ID = GSHIFTMONEYID 
        .ShiftName = GSHIFTMONEYNAME 
        .Note = GSHIFTMONEYSTR 
    End With 
     
    Dim Rst As Recordset 
    Dim i As Integer 
    Dim Sql As String 
    Dim IsToDelete As Boolean 
    Dim isToAdd As Boolean 
    On Error GoTo ShiftErr 
    For i = 1 To UBound(aInnerShift) 
        With aInnerShift(i) 
            IsToDelete = False 
            isToAdd = True 
            Sql = "Select * from Shift where ID=" & .ID 
            Set Rst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot) 
            If Rst.RecordCount > 0 Then 
                If Rst!ShiftName <> Trim(.ShiftName) Then 
                    IsToDelete = True 
                Else 
                    isToAdd = False 
                End If 
            End If 
            Rst.Close 
            Set Rst = Nothing 
            If IsToDelete Then 
                Sql = "delete * from Shift where ID=" & .ID 
                gDataBase.Execute Sql 
            End If 
            If isToAdd Then 
                Sql = "Insert into Shift (ID,ShiftName) values(" & .ID _ 
                    & ",'" & .ShiftName & "')" 
                gDataBase.Execute Sql 
            End If 
        End With 
    Next 
    Exit Sub 
ShiftErr: 
    Err.Clear 
    MsgBox mMsg1, vbExclamation, gTitle 
    EndSystem 
End Sub 
 
Public Sub EndSystem() 
    If Not gDataBase Is Nothing Then 
        gDataBase.Close 
        Set gDataBase = Nothing 
    End If 
    Dim Fr As Form 
    For Each Fr In Forms 
        Unload Fr 
    Next 
End Sub 
Private Sub IniItem(t_table As String, aArray() As ItemStruc) 
    ReDim aArray(0) 
    aArray(0).ID = gMAXITEM 
     
    Dim Rst As Recordset 
    Dim i As Integer 
    Dim isSame As Boolean 
     
    On Error GoTo ErrHandle 
    Set Rst = gDataBase.OpenRecordset("select * from " _ 
        & Trim(t_table) & " Where F_DelFlag=" & gFALSE _ 
        & " order by ID", dbOpenSnapshot) 
     
    While Not Rst.EOF 
        isSame = False 
        For i = 0 To UBound(aArray) 
            If Rst!ID = aArray(i).ID Then 
                isSame = True 
                Exit For 
            End If 
        Next 
        If Not isSame Then 
            ReDim Preserve aArray(UBound(aArray) + 1) 
            With aArray(UBound(aArray)) 
                .ID = Rst!ID 
                .Name = IIf(IsNull(Rst!Name), "", Trim(Rst!Name)) 
            End With 
        End If 
        Rst.MoveNext 
    Wend 
    Rst.Close 
    Set Rst = Nothing 
    Exit Sub 
ErrHandle: 
    Dim er As Error 
    Dim MsgStr As String 
    For Each er In Errors 
        MsgStr = MsgStr & er.Description & er.Number & vbCrLf 
    Next 
    MsgBox MsgStr, , gTitle 
    Resume Next 
End Sub 
 
Public Sub RefreshButton(cmdEdit As Object, Optional intActionAfter As Integer = gCMDEDITNORMAL) 
    Dim i As Integer 
    Select Case intActionAfter 
        Case gCMDAPPEND 
            For i = 0 To cmdEdit.Count - 2 
                With cmdEdit(i) 
                    Select Case i 
                        Case gCMDSAVE, gCMDRETURN, gCMDAPPEND 
                            If Not .Enabled Then .Enabled = True 
                        Case gCMDEDIT, gCMDDELETE, gCMDQUERY 
                            If .Enabled Then .Enabled = False 
                    End Select 
                End With 
            Next 
        Case gCMDEDITNORMAL 
            For i = 0 To cmdEdit.Count - 2 
                With cmdEdit(i) 
                    Select Case i 
                        Case gCMDAPPEND, gCMDQUERY, gCMDRETURN 
                            If Not .Enabled Then .Enabled = True 
                        Case gCMDSAVE, gCMDEDIT, gCMDDELETE 
                            If .Enabled Then .Enabled = False 
                    End Select 
                End With 
            Next 
        Case gCMDEDIT 
            For i = 0 To cmdEdit.Count - 2 
                With cmdEdit(i) 
                    Select Case i 
                        Case gCMDSAVE, gCMDEDIT 
                            If Not .Enabled Then .Enabled = True 
                        Case gCMDAPPEND, gCMDDELETE, gCMDQUERY, gCMDRETURN 
                            If .Enabled Then .Enabled = False 
                    End Select 
                End With 
            Next 
        Case gCMDEDITCANCEL 
            If cmdEdit(gCMDSAVE).Enabled Then cmdEdit(gCMDSAVE).Enabled = False 
    End Select 
End Sub 
 
Public Sub ChangeBackColor(cn As Control, isEdit As Boolean) 
    If isEdit Then 
        cn.BackColor = vbWhite 
    Else 
        cn.BackColor = &H8000000F 
    End If 
End Sub 
 
 
Public Sub ClipToGrid(msfGrid As MSFlexGrid, ClipStr As String, intRows As Integer, intCols As Integer) 
    With msfGrid 
        On Error GoTo ClipErr 
        .Rows = .FixedRows 
        If intRows > .FixedRows Then 
            If .Redraw Then .Redraw = False 
            .Rows = intRows 
            .Cols = intCols 
            .row = .FixedRows 
            .col = .FixedCols 
            .RowSel = .Rows - 1 
            .ColSel = .Cols - 1 
            .Clip = ClipStr 
            .row = .FixedRows 
            .col = 0 
            .Redraw = True 
            .RowHeightMin = 300 
        End If 
    End With 
    Exit Sub 
ClipErr: 
    MsgBox Err.Description, vbExclamation, gTitle 
    Err.Clear 
End Sub 
 
Public Function HasThisTable(TableName As String) As Boolean 
    Dim TD As TableDef 
    For Each TD In gDataBase.TableDefs 
        If TD.Name = TableName Then 
            HasThisTable = True 
            Exit Function 
        End If 
    Next 
    HasThisTable = False 
End Function 
 
Public Function CreateAllRecord(TableName As String) As Boolean 
    Dim intEmp As Integer 
    Dim intDay As Integer 
    Dim Rst As Recordset 
    Dim strWorkNo As String 
    Dim bytDay As Byte 
    Dim bytShift As Byte 
    Dim Sql As String 
     
    bytShift = gNOSHIFT '缺省的 无班次 
     
    On Error GoTo CreateRecErr 
    Set Rst = gDataBase.OpenRecordset("select WorkNo from Employee" _ 
        & " where F_DelFlag=" & gFALSE, dbOpenSnapshot) 
         
    While Not Rst.EOF 
        strWorkNo = Trim(Rst!WorkNo) 
        For intDay = 1 To gMaxDay 
            bytDay = intDay 
            Sql = "Insert into " & TableName & _ 
                " (WorkNo,F_Day,F_Shift) values ('" _ 
                & strWorkNo & "'," & bytDay & "," & bytShift & ")" 
            gDataBase.Execute Sql 
        Next 
        Rst.MoveNext 
    Wend 
     
    Rst.Close 
    Set Rst = Nothing 
    CreateAllRecord = True 
    Exit Function 
CreateRecErr: 
    Err.Clear 
    CreateAllRecord = False 
End Function 
 
 
Public Function CreatePlanTable() As Boolean 
    Dim strTableName As String 
    Dim HasThisTD As Boolean 
    Dim HasRecord As Boolean 
    Dim TD As TableDef 
    Dim Rst As Recordset 
     
    strTableName = gPlanTableName 
     
    HasThisTD = HasThisTable(strTableName) 
     
    If Not HasThisTD Then '无此表 
        If Not CreateATable(strTableName) Then GoTo IniErr 
    End If 
     
    Set Rst = gDataBase.OpenRecordset(strTableName) 
    If Rst.RecordCount > 0 Then HasRecord = True 
    Rst.Close 
    Set Rst = Nothing 
     
    If Not HasRecord Then '无记录 
       If Not CreateAllRecord(strTableName) Then GoTo IniErr 
    End If 
     
    CreatePlanTable = True 
    Exit Function 
IniErr: 
    CreatePlanTable = False 
    Exit Function 
End Function 
 
Public Sub GetPosToCbo(tmpCbo As ComboBox) 
    Dim mSql As String 
    Dim mRst As Recordset 
     
    mSql = "select * from T_Pos order by PosNo" 
    Set mRst = gDataBase.OpenRecordset(mSql) 
    Dim Str As String 
    tmpCbo.Clear 
    While Not mRst.EOF 
        Str = IIf(IsNull(mRst!PosName), "", Trim(mRst!PosName)) 
        tmpCbo.AddItem Str 
        tmpCbo.ItemData(tmpCbo.NewIndex) = mRst!PosNo 
        mRst.MoveNext 
    Wend 
    If tmpCbo.ListCount > 0 Then tmpCbo.ListIndex = 0 
    mRst.Close 
    Set mRst = Nothing 
End Sub 
 
 
Public Function IsNormalKq(IntShift As Integer, strWorkNo As String, strDate As String, strKqTime As String) As Boolean 
    Dim sKqTime As String 
    Dim tmpStr As String 
    Dim mSql As String 
    Dim mRst As Recordset 
     
    strKqTime = Empty 
    mSql = "select F_1On from Shift where ID=" & IntShift _ 
        & " and F_1OnIsKq=" & gTRUE '暂时只适合A段要求考勤的班次 
        '只要在KqHistory中添加F_Section(是哪段考勤) 
    Set mRst = gDataBase.OpenRecordset(mSql, dbOpenSnapshot) 
    If mRst.RecordCount > 0 Then 
        sKqTime = IIf(IsNull(mRst!F_1On), "", Trim(mRst!F_1On)) 
    Else 
        IsNormalKq = False 
        Exit Function 
    End If 
    mRst.Close 
    Set mRst = Nothing 
     
    If sKqTime = Empty Then 
        IsNormalKq = False 
        Exit Function 
    End If 
     
    mSql = "select KqTime from KqHistory " _ 
        & " where KqDate='" & strDate & "'" _ 
        & " and WorkNo='" & strWorkNo & "'" _ 
        & " order by KqTime" 
    Set mRst = gDataBase.OpenRecordset(mSql, dbOpenSnapshot) 
    If mRst.RecordCount > 0 Then 
        tmpStr = IIf(IsNull(mRst!KqTime), "", Trim(mRst!KqTime)) 
    End If 
    mRst.Close 
    Set mRst = Nothing 
     
    If tmpStr = Empty Then 
        IsNormalKq = False 
        'Exit Function 
    Else 
        If sKqTime < tmpStr Then 
            IsNormalKq = False 
        Else 
            IsNormalKq = True 
        End If 
    End If 
    strKqTime = tmpStr 
End Function