zcarloslopes 18/4/2019, 14:27
Obrigado pelo retorno,
Possível é, até porque já consegui, no entanto o código fica demasiado lento.
O formulário é vinculado, é um formulário de manutenção que atualiza campos que podem mudar (nome do chefe, categoria, etc), estes campos irão servir principalmente para manter os relatório atializados, então eu lembrei que poderia fazer o mesmo com os feriados que estão sempre a mudar de acordo com "birras de criança" dos políticos, mas ao invés de ter uma tabela com os feriados, que implica ter que carregar todos os anos, teria apenas uma checkbox que num determinado periodo e/ou localidade pode considerar o feriado ou não.
A ideia seria passar os feriados numa array, e desconsiderar os mesmos na contagem dos dias úteis como acontece com os sábados e domingos.
Segue os exemplos que estou a tentar:
Exemplo que funciona, mas muito lento:
- Código:
Public Function WorkdayDiffHoly(ByVal d1 As Date, ByVal d2 As Date) As Long
Dim diff As Long, sign As Long
Dim wd1 As Integer, wd2 As Integer
Dim AnoNovo As Integer '01/01
Dim DiaLiberdade As Integer '25/04
Dim DiaTrabalhador As Integer '01/05
Dim DiaPortugal As Integer '10/06
Dim StoAntonio As Integer '13/6
Dim SaoJoao As Integer '24/06
Dim NossaSenhora As Integer '15/08
Dim Republica As Integer '05/10
Dim TodosSantos As Integer '01/11
Dim Independencia As Integer '01/12
Dim Imaculada As Integer '08/12
Dim Natal As Integer '25/12
Dim Carnaval As Integer 'Móvel
Dim SextaSanta As Integer 'Móvel
Dim Pascoa As Integer 'Móvel
Dim CorpoDeus As Integer 'Móvel
Dim SraMatosinhos As Integer 'Móvel
'USAGE:
'WorkdayDiffHoly(field1, field2)
diff = DateDiff("d", d1, d2)
If diff < 0 Then
'* Effectively swap d1 and d2; reverse sign
diff = -diff
sign = -1
wd1 = Weekday(d2)
Else
sign = 1
wd1 = Weekday(d1)
End If
wd2 = (wd1 + diff - 1) Mod 7 + 1
If (wd1 = 1 And diff = 0) Or (wd1 = 7 And diff <= 1) Then
WorkdayDiffHoly = 0 '* Both dates are on same weekend
Exit Function
End If
'* If starting or ending date fall on weekend, shift to closest weekday
'* since the weekends should not contribute to the sum.
'* This shift is critical for the last If condition and arithmetic.
If wd1 = 1 Then
wd1 = 2 '* Shift to Monday
diff = diff - 1
ElseIf wd1 = 7 Then
wd1 = 2 '* Shift to Monday
diff = diff - 2
End If
If wd2 = 1 Then
diff = diff - 2 '* Shift to Friday
ElseIf wd2 = 7 Then
diff = diff - 1 '* Shift to Friday
End If
'* If difference goes beyond weekend boundary then...
If diff >= 7 - wd1 Then
'* Normalize span to start on Monday for modulus arithmetic
'* then remove weekend days
diff = diff - ((diff + (wd1 - 2)) \ 7) * 2
End If
'Ano Novo (1 de Janeiro) - Fixo
If (((DateSerial(year(d1), 1, 1)) >= d1 And (DateSerial(year(d1), 1, 1)) <= d2 And _
Weekday(DateSerial(year(d1), 1, 1)) <> 7 And Weekday(DateSerial(year(d1), 1, 1)) <> 1) And _
DLookup("chkAnoNovo", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
AnoNovo = 1
Else
AnoNovo = 0
End If
'Dia da Liberdade (25 de Abril) - Fixo
If (((DateSerial(year(d1), 4, 25)) >= d1 And (DateSerial(year(d1), 4, 25)) <= d2 And _
Weekday(DateSerial(year(d1), 4, 25)) <> 7 And Weekday(DateSerial(year(d1), 4, 25)) <> 1) And _
DLookup("chkDiaLiberdade", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
DiaLiberdade = 1
Else
DiaLiberdade = 0
End If
'Dia do Trabalhador (1 de Maio) - Fixo
If (((DateSerial(year(d1), 5, 1)) >= d1 And (DateSerial(year(d1), 5, 1)) <= d2 And _
Weekday(DateSerial(year(d1), 5, 1)) <> 7 And Weekday(DateSerial(year(d1), 5, 1)) <> 1) And _
DLookup("chkDiaTrabalhador", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
DiaTrabalhador = 1
Else
DiaTrabalhador = 0
End If
'Dia do Portugal (10 de Junho) - Fixo
If (((DateSerial(year(d1), 6, 10)) >= d1 And (DateSerial(year(d1), 6, 10)) <= d2 And _
Weekday(DateSerial(year(d1), 6, 10)) <> 7 And Weekday(DateSerial(year(d1), 6, 10)) <> 1) And _
DLookup("chkDiaPortugal", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
DiaPortugal = 1
Else
DiaPortugal = 0
End If
'Santo António (13 de Junho) - Fixo
If (((DateSerial(year(d1), 6, 13)) >= d1 And (DateSerial(year(d1), 6, 13)) <= d2 And _
Weekday(DateSerial(year(d1), 6, 13)) <> 7 And Weekday(DateSerial(year(d1), 6, 13)) <> 1) And _
DLookup("chkSantoAntonio", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
StoAntonio = 1
Else
StoAntonio = 0
End If
'São João (24 de Junho) - Fixo
If (((DateSerial(year(d1), 6, 24)) >= d1 And (DateSerial(year(d1), 6, 24)) <= d2 And _
Weekday(DateSerial(year(d1), 6, 24)) <> 7 And Weekday(DateSerial(year(d1), 6, 24)) <> 1) And _
DLookup("chkSaoJoao", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
SaoJoao = 1
Else
SaoJoao = 0
End If
'Assunção de Nossa Senhora (15 de Agosto) - Fixo
If (((DateSerial(year(d1), 8, 15)) >= d1 And (DateSerial(year(d1), 8, 15)) <= d2 And _
Weekday(DateSerial(year(d1), 8, 15)) <> 7 And Weekday(DateSerial(year(d1), 8, 15)) <> 1) And _
DLookup("chkNossaSenhora", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
NossaSenhora = 1
Else
NossaSenhora = 0
End If
'Implantação da República (5 de Outubro) - Fixo
If (((DateSerial(year(d1), 10, 5)) >= d1 And (DateSerial(year(d1), 10, 5)) <= d2 And _
Weekday(DateSerial(year(d1), 10, 5)) <> 7 And Weekday(DateSerial(year(d1), 10, 5)) <> 1) And _
DLookup("chkImplRepublica", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Republica = 1
Else
Republica = 0
End If
'Dia de Todos os Santos (1 de Novembro) - Fixo
If (((DateSerial(year(d1), 11, 1)) >= d1 And (DateSerial(year(d1), 11, 1)) <= d2 And _
Weekday(DateSerial(year(d1), 11, 1)) <> 7 And Weekday(DateSerial(year(d1), 11, 1)) <> 1) And _
DLookup("chkTodosSantos", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
TodosSantos = 1
Else
TodosSantos = 0
End If
'Restauração da Independência (1 de Dezembro) - Fixo
If (((DateSerial(year(d1), 12, 1)) >= d1 And (DateSerial(year(d1), 12, 1)) <= d2 And _
Weekday(DateSerial(year(d1), 12, 1)) <> 7 And Weekday(DateSerial(year(d1), 12, 1)) <> 1) And _
DLookup("chkIndependencia", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Independencia = 1
Else
Independencia = 0
End If
'Dia da Imaculada Conceição (8 de Dezembro) - Fixo
If (((DateSerial(year(d1), 12, 8)) >= d1 And (DateSerial(year(d1), 12, 8)) <= d2 And _
Weekday(DateSerial(year(d1), 12, 8)) <> 7 And Weekday(DateSerial(year(d1), 12, 8)) <> 1) And _
DLookup("chkImaculada", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Imaculada = 1
Else
Imaculada = 0
End If
'Natal (25 de Dezembro) - Fixo
If (((DateSerial(year(d1), 12, 25)) >= d1 And (DateSerial(year(d1), 12, 25)) <= d2 And _
Weekday(DateSerial(year(d1), 12, 25)) <> 7 And Weekday(DateSerial(year(d1), 12, 25)) <> 1) And _
DLookup("chkNatal", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Natal = 1
Else
Natal = 0
End If
'Carnaval (Páscoa - 47) - Móvel
If (((EasterDate2(year(d1)) - 47) >= d1 And (EasterDate2(year(d1)) - 47) <= d2 And _
(EasterDate2(year(d1)) - 47) <> (DateSerial(year(d1), 4, 25))) And _
DLookup("chkCarnaval", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Carnaval = 1 'Nuca é ao domingo
Else
Carnaval = 0
End If
'Sexta-Feira Santa (Páscoa - 2) - Móvel
If (((EasterDate2(year(d1)) - 2) >= d1 And (EasterDate2(year(d1)) - 2) <= d2 And _
(EasterDate2(year(d1)) - 2) <> (DateSerial(year(d1), 4, 25))) And _
DLookup("chkSextaSanta", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
SextaSanta = 1 'Nuca é ao domingo
Else
SextaSanta = 0
End If
'Páscoa - Móvel
If (((EasterDate2(year(d1))) >= d1 And (EasterDate2(year(d1))) <= d2) And _
DLookup("chkPascoa", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
Pascoa = 0 'Páscoa é sempre ao domingo
Else
Pascoa = 0
End If
'Corpo de Deus (Páscoa + 60) - Móvel
If (((EasterDate2(year(d1)) + 60) >= d1 And (EasterDate2(year(d1)) + 60) <= d2 And _
(EasterDate2(year(d1)) + 60) <> (DateSerial(year(d1), 4, 25)) And _
(EasterDate2(year(d1)) + 60) <> (DateSerial(year(d1), 5, 1)) And _
(EasterDate2(year(d1)) + 60) <> (DateSerial(year(d1), 6, 10))) And _
DLookup("chkCorpoDeus", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
CorpoDeus = 1 'Nuca é ao domingo
Else
CorpoDeus = 0
End If
'Senhora de Matosinhos(Páscoa + 51) - Móvel
If (((EasterDate2(year(d1)) + 51) >= d1 And (EasterDate2(year(d1)) + 51) <= d2 And _
(EasterDate2(year(d1)) + 51) <> (DateSerial(year(d1), 4, 25)) And _
(EasterDate2(year(d1)) + 51) <> (DateSerial(year(d1), 5, 1)) And _
(EasterDate2(year(d1)) + 51) <> (DateSerial(year(d1), 6, 10))) And _
DLookup("chkSenhoraMatosinhos", "tbl_SEFT_CamposRelatorios", "ID = 1") = -1) Then
SraMatosinhos = 1 'Nuca é ao domingo
Else
SraMatosinhos = 0
End If
WorkdayDiffHoly = (sign * (diff + 1)) - AnoNovo - DiaLiberdade - DiaTrabalhador - DiaPortugal - _
NossaSenhora - Republica - TodosSantos - Independencia - SaoJoao - _
Imaculada - Natal - Carnaval - SextaSanta - Pascoa - CorpoDeus - StoAntonio - SraMatosinhos
End Function
A função Páscoa de apoio ao código acima:
- Código:
Option Compare Database
Public Function EasterDate2(Yr As Integer) As Date
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
EasterDate2 = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - ((Yr + Yr \ 4 + _
D + (D > 48) + 1) Mod 7)
End Function
O que estou tentando é adaptar a array abaixo na primeira função, ou noutra que funcione:
- Código:
Function isExclude(testDate As Date) As Boolean
Dim excludeDates(1 To 17) As Date
Dim intyear As Integer
intyear = Format(testDate, "YYYY")
Dim I As Integer
'Lista de Feriados
'''''''''''''''''''''''''''''''''''''''''''''
excludeDates(1) = CDate("1/1/" & intyear) 'Ano Novo
excludeDates(2) = CDate("4/25/" & intyear) 'Dia da Liberdade
excludeDates(3) = CDate("5/1/" & intyear) 'Dia do Trabalhador
excludeDates(4) = CDate("6/10/" & intyear) 'Dia de Portugal
excludeDates(5) = CDate("6/13/" & intyear) 'Santo António
excludeDates(6) = CDate("6/24/" & intyear) 'São João
excludeDates(7) = CDate("8/15/" & intyear) 'Assunção de Nossa Senhora
excludeDates(8) = CDate("10/5/" & intyear) 'Implantação da República
excludeDates(9) = CDate("11/1/" & intyear) 'Todos os Santos
excludeDates(10) = CDate("12/1/" & intyear) 'Restauração da Independência
excludeDates(11) = CDate("12/8/" & intyear) 'Imaculada Conceição
excludeDates(12) = CDate("12/25/" & intyear) 'Natal
'Feriados Móveis
excludeDates(13) = dt_Pascoa ' Páscoa
excludeDates(14) = dt_Carnaval 'Carnaval
excludeDates(15) = dt_SextaSanta 'Sexta-feira Santa
excludeDates(16) = dt_Matosinhos 'Senhora de Matosinhos
excludeDates(17) = dt_CorpusC 'Corpo de Deus
For I = 1 To 17
If testDate = excludeDates(I) Then
isExclude = True
Exit Function
End If
Next I
isExclude = False
End Function
Function isWeekend(testDate As Date) As Boolean
Select Case Weekday(testDate)
Case vbSaturday, vbSunday
isWeekend = True
Case Else
isWeekend = False
End Select
End Function
Public Function fncFeriadosMoveis(ano%) As String
Dim dt_Pascoa As Date
Dim dt_Carnaval As Date
Dim dt_SextaSanta As Date
Dim dt_CorpusC As Date
Dim dt_Matosinhos As Date
Dim A%, B%, C%, D%, E%, F%, G%, H%, I%, k%, L%, M%, P%, Q%
A = (ano Mod 19)
B = Int(ano / 100)
C = (ano Mod 100)
D = Int(B / 4)
E = (B Mod 4)
F = Int((B + / 25)
G = Int((B - F + 1) / 3)
H = ((19 * A + B - D - G + 15) Mod 30)
I = Int(C / 4): k = (C Mod 4)
L = ((32 + 2 * E + 2 * I - H - k) Mod 7)
M = Int((A + 11 * H + 22 * L) / 451)
P = Int((H + L - 7 * M + 114) / 31)
Q = ((H + L - 7 * M + 114) Mod 31)
dt_Pascoa = CDate((Q + 1) & "/" & P & "/" & ano)
dt_Carnaval = DateAdd("d", -47, dt_Pascoa)
dt_SextaSanta = DateAdd("d", -2, dt_Pascoa)
dt_Matosinhos = DateAdd("d", 51, dt_Pascoa)
dt_CorpusC = DateAdd("d", 60, dt_Pascoa)
End Function
Nesta array falta ainda colocar a condição se a checkbox = -1 para cada feriado.
Alguma ideia seria muito bem vinda.
Obrigado