alterar código

[José luis leal]

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

[tiago.f]

Olá Luis,

já é o 3º tópico que abres com a mesma questão.

Porque marcar os outro tópicos como resolvidos se de facto não estão??

Isto conta 8 horas por dia:

Option Compare Database
Option Explicit

Public Function DTS(dtInicio As Date, dtFim As Date) 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



   'Entrada 8:00
   'Saída para almoço 12:30
   'Reentrada 13:30
   'Saída 18:00

   Set DB = CurrentDb
   Set rst = DB.OpenRecordset( _
       "SELECT [FerData] FROM tblFeriados WHERE [FerData] BETWEEN #" & Format(dtInicio, "mm/dd/yyyy") & "# AND #" & Format(dtFim, "mm/dd/yyyy") & "#", _
       dbOpenSnapshot)

   Dim numberOfRows As Integer, numberOfWorkingDays As Integer

   numberOfRows = rst.RecordCount
   numberOfWorkingDays = Work_Days(dtInicio, dtFim)

   DTS = (numberOfWorkingDays - numberOfRows) * 8

Exit_DTS:
   Exit Function

Err_DTS:
   Select Case Err

   Case Else
       MsgBox Err.Description
       Resume Exit_DTS
   End Select

End Function

'*********** Code End **************


Function Work_Days(bd, ed)
  Const SUNDAY = 1
  Const SATURDAY = 7
  Dim NumWeeks As Integer
  Dim BegDate As Variant, EndDate As Variant
  BegDate = bd
  EndDate = ed

  If BegDate > EndDate Then
     Work_Days = 0
  Else
     Select Case Weekday(BegDate)
        Case SUNDAY: BegDate = BegDate + 1
        Case SATURDAY: BegDate = BegDate + 2
     End Select
     Select Case Weekday(EndDate)
        Case SUNDAY: EndDate = EndDate - 2
        Case SATURDAY: EndDate = EndDate - 1
     End Select
     NumWeeks = DateDiff("ww", BegDate, EndDate)
     Work_Days = NumWeeks * 5 + Weekday(EndDate) - Weekday(BegDate) + 1
  End If
End Function