Alterar código

[feio134]

Boa noite!
Alguém fazia o favor de fazer com que este código conta-se só 8 horas por cada dia util
 

Option Compare Database
Option Explicit
Public Function DTS(dtInicio As Date, dtFim As Date, Optional HojeTb As Boolean = False, Optional UltTb As Boolean = False) As Integer
'....................................................................
' Nome:  DTS
' Entradas: dtInicio As Date
'                  dtFim As Date
'                  HojeTb As Boolean
'                  UltTb As Boolean
' Saída:    Integer
' Autor:    Arvin Meyer
' Data:  Maio 5,2002
' Comentário: Aceita duas datas e devolve o número de dias úteis
'                        entre elas. Note-se que esta função considera os feriados
'                        do período. Ela exige a existência de uma tabela chamada
'                        tblFeriados com um campo, no formato data, chamado FerData.
'                        Se HojeTb = True, a data inicial também será considerada.
'                        Se UltTb = true, a data final também será considerada.
'....................................................................
On Error GoTo Err_DTS
Dim intCount As Integer
Dim rst As DAO.Recordset
Dim DB As DAO.Database
    Set DB = CurrentDb
    Set rst = DB.OpenRecordset("SELECT [FerData] FROM tblFeriados", dbOpenSnapshot)
    If Not HojeTb Then
            dtInicio = dtInicio + 1
    End If
' Se desejar contar a data de início, passe True em HojeTb
    intCount = 0
    If UltTb Then
            Do While dtInicio <= dtFim
                    rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy") & "#"
                    If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then
                            If rst.NoMatch Then intCount = intCount + 1
                    End If
                    dtInicio = dtInicio + 1
            Loop
    Else
            Do While dtInicio < dtFim
                    rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy") & "#"
                    If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then
                            If rst.NoMatch Then intCount = intCount + 1
                    End If
                    dtInicio = dtInicio + 1
            Loop
    End If
    DTS = intCount
Exit_DTS:
Exit Function
Err_DTS:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_DTS
End Select
End Function
'*********** Code End **************
Voltar ao TopoEditar/excluir esta mensagemExcluir esta mensagem