其他数据库

开发平台：
Visual Basic

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 + "datakq.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
    
    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

						