modulemain.bas

考勤机管理软件,用于统计某段时间某个部门或者某个员工在某段内迟到与早退次数.

        End If
    Next
    
    GetClassID = 0
End Function

'==========利时间位置，休息名称，日期，判断是否休假
Public Function GetYesNoVac(ByVal lEmployeeID As Long, ByVal lTimePos As Long, ByVal sVacID As Long, ByVal sDate As String) As Boolean

    Dim LeaveTimePos As Long
    
    If lTimePos Mod 2 = 1 Then
        LeaveTimePos = (lTimePos + 1) / 2
    ElseIf lTimePos Mod 2 = 0 Then
        LeaveTimePos = lTimePos / 2
    End If
    
    Dim i As Integer
    Dim dtm As Date
    Dim iWeek As Integer
    Dim lDay As Long
    Dim upBound As Long
    
    If blnSetVacTypeInfo = True Then
    
        upBound = UBound(SetVacTypeInfo)
        For i = 1 To upBound
            If SetVacTypeInfo(i).EmployeeID = lEmployeeID Then
                '======0是全天
                If sDate >= SetVacTypeInfo(i).BeginDate And sDate <= SetVacTypeInfo(i).EndDate Then
                
'                    If Val(SetVacTypeInfo(i).TimePos) <> 0 And Val(SetVacTypeInfo(i).TimePos) <> LeaveTimePos Then
'                        GetYesNoVac = False
'                        Exit Function
'                    End If
                    
                    If SetVacTypeInfo(i).TimeMode = 0 Then
                    
                        If Val(SetVacTypeInfo(i).TimePos) <> 0 And Val(SetVacTypeInfo(i).TimePos) <> LeaveTimePos Then
                            GetYesNoVac = False
                            Exit Function
                        Else
                            GetYesNoVac = True
                            Exit Function
                        End If
                        
                    ElseIf SetVacTypeInfo(i).TimeMode = 1 Then
                        
                        dtm = CDate(sDate)
                        iWeek = Weekday(dtm)
                        
                        If iWeek = 1 Then iWeek = 7 Else iWeek = iWeek - 1
                               
                        If iWeek >= SetVacTypeInfo(i).BeginTime And iWeek <= SetVacTypeInfo(i).EndTime Then
                        
                            If Val(SetVacTypeInfo(i).TimePos) <> 0 And Val(SetVacTypeInfo(i).TimePos) <> LeaveTimePos Then
                                GetYesNoVac = False
                                Exit Function
                            Else
                                GetYesNoVac = True
                                Exit Function
                            End If
                            
                        End If
                    
                    ElseIf SetVacTypeInfo(i).TimeMode = 2 Then
                    
                        lDay = Right(sDate, 2)
        
                        If (lDay >= SetVacTypeInfo(i).BeginTime) And (lDay <= SetVacTypeInfo(i).EndTime) Then
                        
                            If Val(SetVacTypeInfo(i).TimePos) <> 0 And Val(SetVacTypeInfo(i).TimePos) <> LeaveTimePos Then
                                GetYesNoVac = False
                                Exit Function
                            Else
                                GetYesNoVac = True
                                Exit Function
                            End If
                            
                        End If
                    
                    End If
                        
                End If
                
            End If
            
        Next
        
    End If
    
    
    If blnVacTypeInfo = True Then
    
        upBound = UBound(VacTypeInfo)
        For i = 1 To upBound
            If VacTypeInfo(i).VacID = sVacID Then
                '======0是全天
                If VacTypeInfo(i).TimePos = 0 Or VacTypeInfo(i).TimePos = LeaveTimePos Then
                
                    If sDate >= VacTypeInfo(i).BeginDate And sDate <= VacTypeInfo(i).EndDate Then
                    
                        If VacTypeInfo(i).TimeMode = 0 Then
                        
                            GetYesNoVac = True
                            Exit Function
                            
                        ElseIf VacTypeInfo(i).TimeMode = 1 Then
                            
                            dtm = CDate(sDate)
                            iWeek = Weekday(dtm)
                            
                            If iWeek = 1 Then iWeek = 7 Else iWeek = iWeek - 1
                                   
                            If iWeek >= VacTypeInfo(i).BeginTime And iWeek <= VacTypeInfo(i).EndTime Then
                                GetYesNoVac = True
                                Exit Function
                            End If
                        
                        ElseIf VacTypeInfo(i).TimeMode = 2 Then
                        
                            lDay = Right(sDate, 2)
            
                            If (lDay >= VacTypeInfo(i).BeginTime) And (lDay <= VacTypeInfo(i).EndTime) Then
                                GetYesNoVac = True
                                Exit Function
                            End If
                        
                        End If
                        
                    End If
                    
                End If
                
            End If
            
        Next
    End If

End Function

'=========利用员工名称，时间位置，日期，判断是否请假
Public Function GetYesNoLeave(ByVal lEmployeeID As Long, ByVal lTimePos As Long, ByVal sDate As String) As Boolean

    If blnLeaveTypeInfo = False Then Exit Function


    Dim dtm As Date
    Dim iWeek As Integer
    Dim lDay As Long



    Dim LeaveTimePos As Long
    If lTimePos Mod 2 = 1 Then
        LeaveTimePos = (lTimePos + 1) / 2
    ElseIf lTimePos Mod 2 = 0 Then
        LeaveTimePos = lTimePos / 2
    End If
    
    Dim upBound As Long
    upBound = UBound(LeaveTypeInfo)
    
    Dim i As Integer
    For i = 1 To upBound
        If LeaveTypeInfo(i).EmployeeID = lEmployeeID Then
            If LeaveTypeInfo(i).TimePos = 0 Or LeaveTypeInfo(i).TimePos = LeaveTimePos Then
            
'                If CDate(LeaveTypeInfo(i).BeginTime) <= CDate(sDate) And CDate(LeaveTypeInfo(i).EndTime) >= CDate(sDate) Then
'                    GetYesNoLeave = True
'                    Exit Function
'                End If

                If sDate >= LeaveTypeInfo(i).BeginDate And sDate <= LeaveTypeInfo(i).EndDate Then
                
                    If LeaveTypeInfo(i).TimeMode = 0 Then
                    
                        GetYesNoLeave = True
                        Exit Function
                        
                    ElseIf LeaveTypeInfo(i).TimeMode = 1 Then
                        
                        dtm = CDate(sDate)
                        iWeek = Weekday(dtm)
                        
                        If iWeek = 1 Then iWeek = 7 Else iWeek = iWeek - 1
                               
                        If iWeek >= LeaveTypeInfo(i).BeginTime And iWeek <= LeaveTypeInfo(i).EndTime Then
                            GetYesNoLeave = True
                            Exit Function
                        End If
                    
                    ElseIf LeaveTypeInfo(i).TimeMode = 2 Then
                    
                        lDay = Right(sDate, 2)
        
                        If (lDay >= LeaveTypeInfo(i).BeginTime) And (lDay <= LeaveTypeInfo(i).EndTime) Then
                            GetYesNoLeave = True
                            Exit Function
                        End If
                    
                    End If
                    
                End If


            
            End If
        End If
    Next
    

    
    
    
    
    
    

End Function


'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串,标题,保存文件名称)
'*********************************************************
Public Function ExporToExcel(Rs_Data As ADODB.Recordset, strCaption As String, strFilename As String)
On Error GoTo DealErr

    DoEvents

    Dim Irowcount As Integer
    Dim Icolcount As Integer

    Dim xlApp As New Excel.Application
    'Dim xlApp As Object
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable

    With Rs_Data
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count

    End With

    If Not (xlApp Is Nothing) Then Set xlApp = Nothing
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add

    Set xlSheet = xlApp.ActiveWorkbook.Sheets(1) 'Set xlSheet = xlBook.Worksheets("sheet1")
    xlSheet.Name = strCaption
    Debug.Print xlSheet.Name
    xlApp.Visible = False
    xlApp.Application.Visible = False
    xlApp.Interactive = False

    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("A1"))

    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With

    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh

    With xlSheet
    
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "宋体" '设标题为宋体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True  '标题字体加粗
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Size = 13
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '设表格边框样式

    End With

    '==保存Excel File
    If Dir(strFilename) <> "" Then Kill strFilename
    xlBook.SaveAs strFilename

    '===释放资源
    If Not (xlQuery Is Nothing) Then Set xlQuery = Nothing
    If Not (xlSheet Is Nothing) Then Set xlSheet = Nothing
    If Not (xlBook Is Nothing) Then Set xlBook = Nothing
    xlApp.Quit
    If Not (xlApp Is Nothing) Then Set xlApp = Nothing

    DoEvents
    
    Exit Function
    
DealErr:
 
   MsgBox Err.Description, vbCritical, "出错"

End Function


Public Function FindWindow(Name As String) As Boolean

    Dim i As Integer
    For i = 1 To Forms.Count
        If Forms(i - 1).Name = Name Then
            FindWindow = True
            Exit Function
        End If
    Next
    
End Function

Public Sub Message(ByVal Msg As String)
    MsgBox Msg, vbInformation, "提示"
End Sub

Public Function QueryDly(Msg As String) As Boolean
    If MsgBox(Msg, vbQuestion + vbYesNo, "询问") = vbYes Then QueryDly = True
End Function

Public Function ChangedBox(Msg As String) As Long
    ChangedBox = MsgBox(Msg, vbQuestion + vbYesNoCancel, "询问")
End Function


Public Function ChangedMsg() As Boolean
    ChangedMsg = True
    Dim l As Long
    If Screen.ActiveForm.m_Changed = True Then l = ChangedBox("记录已更改,是否保存?")
    If l = vbYes Then
        If Screen.ActiveForm.SaveBill = False Then ChangedMsg = False
    ElseIf l = vbNo Then
        ChangedMsg = True
    ElseIf l = vbCancel Then
        ChangedMsg = False
    End If
End Function











Public Sub MsgNotFound()
    MsgBox "没有找到相应的记录！", vbExclamation + vbOKOnly, "提示"
End Sub

Public Sub MsgNotNull(sField As String)
    MsgBox sField & "不能为空,请输入数据!", vbExclamation + vbOKOnly, "提交数据失败"
End Sub


Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)

'    Dim db As Database
'
'    Dim rs As Recordset
'
'    Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
'
'    Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
'
'    MsgBox "Table exported successfully.", vbInformation, "Yams"

End Sub

'使用范例如下：將 C:\book1.xls 中的 Sheet1 导入 C:\Test.mdb 成为 TestTable
'ExportExcelSheetToAccess "Sheet1", "C:\book1.xls", "TestTable", "C:\Test.mdb"








Public Sub ErrMsg()
    If InStr(Err.Description, "中了包含相关记录") <> 0 Then
        Message "该记录被其它地方引用,不能删除!"
    ElseIf InStr(Err.Description, "创建重复的值") <> 0 Then
        Message "输入的数据与数据库内有重复!"
    Else
        Message Err.Description
    End If
    
    Err.Clear
End Sub