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
    
    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