[Resolvido]Escala de Folga

Boa tarde a Todos

Uso este código abaixo Criado pelo Mestre Avelino e Mestre Alexandre Neves para um amigo do fórum para controlar dias uteis para vencimentos, que por sinal esta perfeito e tambem uso para esta finalidade.
Agora a empresa quer criar um método de premiação que seria a cada trimestre sem falta o funcionário teria direito a 3 dias úteis de folga que seria agendado através de datas disponíveis.
Criei a tabela de agendamento "tblagenda" com campo data e Funcionário e criei o frmagenda
quando seleciono o funcionario queria estipular qual periodo ele estara de folga

Gostaria de adaptar este código se for possível para efetuar este agendamento.
Preciso que quando informo o funcionário e a data no formulário ele Leia esta tabela e se já existe uma data me informe através de de mensagem que já existe funcionário(Nome) agendado e ele agende para próxima data descontando finais de semana e feriados e grave na tabela os tres dias úteis de folga para funcionario selecionado.

Será que é Possivel?

Código:

Public Function fncAjustaData(dataInformada As Date, Optional status As Boolean) As Date
Dim k, F, j%, NovaData As Date
Static feriado
feriado = IIf(status = True, Null, feriado)
k = Split(fncFeriadosMoveis(Year(dataInformada)) & ",0101,0421,0501,0907,1012,1102,1115,1120,1225", ",")
F = Split("Carnaval,Sexta Santa,Corpus Crist,Confraternização Universal,Tiradente,Dia do Trabalhador,Independência do Brasil,Nossa Senhora Aparecida,Finados,Proclamação da República,Dia da Consciência Negra,Natal", ",")
NovaData = dataInformada
For j = 0 To UBound(k)
If k(j) = Format(dataInformada, "mmdd") Then
NovaData = dataInformada + 1
feriado = "feriado (" & F(j) & ")"
Exit For
End If
Next
If Weekday(NovaData) = 7 Then
NovaData = NovaData + 2
feriado = "Sábado"
End If
If Weekday(NovaData) = 1 Then
NovaData = NovaData + 1
feriado = "Domingo"
End If
If NovaData <> dataInformada Then NovaData = fncAjustaData(NovaData)
If (NovaData = dataInformada) And Not IsNull(feriado) Then MsgBox "Esta data cairá no " & feriado & vbCrLf & vbNewLine & "Será reagendado para: " & NovaData & " (" & WeekdayName(Weekday(NovaData)) & ")", vbInformation, "Aviso"
fncAjustaData = NovaData
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 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 + 8 )/ 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_CorpusC = DateAdd("d", 60, dt_Pascoa)

fncFeriadosMoveis = Format(dt_Carnaval, "mmdd") & "," & Format(dt_SextaSanta, "mmdd") & "," & Format(dt_CorpusC, "mmdd")
End Function


Aguardo Ajuda

Abraços

UP

Bom dia

Existe uma solução neste tópico que talvez me ajudaria, mas não tenho o link
do resultado apresentado pelo Mestre Avelino Sampaio.
Ficaria Grato se Alguem pudesse me ajudar

http://maximoaccess.forumeiros.com/t10830-resolvidocalculo-de-prazo-com-dias-uteis-feriados-e-recesso#87070

Abraços

Boa tarde.
Já tem a parte de verificação de agendamento existente?
Como são calculadas as datas disponíveis?

Boa Tarde Alexandre Neves

Então, a Idéia seria tentar incluir na função acima a "tblagenda"
com campos dtinicio, dtfinal e funcionario e quando ao selecionar no frmagenda em um combo o nome do funcionário que vem da tblfuncionarios e digitar data Inicio e data Final pretendida por ele para folga, a função verifique se já existe agendamento para data solicitada e se caso exista informe uma nova sequencia de trez(3) dias úteis e grave na tabela.
Exemplo: se já existe agenda para 17/7,18/7,21/7 (19/7 e 20/7 = sabado e domindo), proxima seria 22/7,23/7,24/7, caso exista 22/7,23/7,24/7, próxima seria 25/7, 28/7,29/7 (26/7 e 27/7= final de semana) e que se exista algum feriado que também pule igual final de semana.

se precisar de mais informações por favor, fique a vontate

Abraços

Olá Alexandre

Encontrei este código e me desculpe não sei o autor, tentei encontrar novamente o tópico para ver o autor mas não encontrei e tambem como meu conhecimento em vb é muito precário não consegui adaptar.

Function ÉFeriado(Data) As Boolean
On Error GoTo Err_ÉFeriado

If IsNull(Data) Then Exit Function

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, k%, l%, m%, p%, q%
Dim intAno As Integer, intConta As Integer
Dim Pascoa As Date, varData() As Date
Dim ExisteTabela As Boolean

Set db = CurrentDb
ÉFeriado = False
intAno = Year(CDate(Data))

' Calcula a data da Páscoa
If intAno >= 1583 Then ' Jean Baptiste Joseph Delambre (1749-1822)
a = intAno Mod 19
b = Fix(intAno / 100)
c = intAno Mod 100
d = Fix(b / 4)
e = b Mod 4
f = Fix((b + / 25)
g = Fix((b - f + 1) / 3)
h = (19 * a + b - d - g + 15) Mod 30
i = Fix(c / 4)
k = c Mod 4
l = (32 + 2 * e + 2 * i - h - k) Mod 7
m = Fix((a + 11 * h + 22 * l) / 451)
p = Fix((h + l - 7 * m + 114) / 31)
q = (h + l - 7 * m + 114) Mod 31
Pascoa = DateSerial(intAno, p, q + 1)
Else ' Calendário Juliano
a = intAno Mod 4
b = intAno Mod 7
c = intAno Mod 19
d = (19 * c + 15) Mod 30
e = (2 * a + 4 * b - d + 34) Mod 7
f = Fix((d + e + 114) / 31)
g = (d + e + 114) Mod 31
Pascoa = DateSerial(intAno, f, g + 1)
End If

' Verifica a existência da tabela tblFeriados
ExisteTabela = (DCount("Name", "MSysObjects", "Name = 'tblFeriados'") > 0)

' Dimensiona a matriz
If ExisteTabela Then
Set rs = db.OpenRecordset("tblFeriados", dbOpenSnapshot)
If rs.EOF = False Then
rs.MoveLast
ReDim varData(15 + rs.RecordCount)
Else
ReDim varData(15)
End If
Else
ReDim varData(15)
End If

' Define feriados móveis
varData(0) = Pascoa - 48 ' Segunda-feira de Carnaval
varData(1) = Pascoa - 47 ' Terça-feira de Carnaval
varData(2) = Pascoa - 2 ' Paixão de Cristo
varData(3) = Pascoa ' Páscoa
varData(4) = Pascoa + 60 ' Corpus Christi

' Feriados Nacionais (lei 10.607/2002)
varData(5) = CDate("01/01/" & intAno) ' Confraternização Universal
varData(6) = CDate("21/04/" & intAno) ' Tiradentes
varData(7) = CDate("01/05/" & intAno) ' Dia do trabalho
varData( = CDate("07/09/" & intAno) ' Independência do Brasil
varData(9) = CDate("12/10/" & intAno) ' Padroeira do Brasil
varData(10) = CDate("02/11/" & intAno) ' Finados
varData(11) = CDate("15/11/" & intAno) ' Proclamação da República
varData(12) = CDate("25/12/" & intAno) ' Natal

' Feriados Estatual (lei 00.000/0000)
varData(13) = CDate("09/07/" & intAno) ' Revolução Constitucionalista de 1932
varData(14) = CDate("20/11/" & intAno) ' Dia da Consciência Negra

' Feriados Municipal (lei 00.000/0000)
varData(15) = CDate("21/01/" & intAno) ' Aniversário da cidade de São Paulo

' Carrega feriados regionais com base na tabela tblFeriados
If ExisteTabela Then
If rs.EOF = False Then
rs.MoveFirst
For intConta = 16 To UBound(varData)
varData(intConta) = CDate(rs("Dia_Mês") & "/" & intAno)
rs.MoveNext
Next
End If
End If

' Verifica data
For intConta = 0 To UBound(varData)
If CDate(Data) = varData(intConta) Then
ÉFeriado = True
End If
Next

Sai:
Set rs = Nothing
Set db = Nothing
Exit Function

Err_ÉFeriado:
MsgBox "Erro: " & Err.Number & " - " & Err.Description
Resume Sai

End Function

Abraços

A autoria da função ÉFeriado será do Renato Santos (http://www.accessfaq.com.br/webroot/default.asp?http%3A//www.accessfaq.com.br/webroot/detalhe.asp%3FPergunta_Id%3D89)

Sobre a sua necessidade, teria de incluir o número do funcionário na procura da agenda e, assim, teria de ter argumento para o efeito.
Com a permissão do Mestre Avelino, alterei o código e teste-o (esta função substitui a função fncAjustaData
Public Function DataDisponivel(DataInformada As Date,NrFuncionario as integer) As Date
Dim k, F, j%, NovaData As Date
k = Split(fncFeriadosMoveis(Year(dataInformada)) & ",0101,0421,0501,0907,1012,1102,1115,1120,1225", ",")
For j = 0 To UBound(k)
If k(j) = Format(dataInformada, "mmdd") Then
NovaData = dataInformada + 1
Exit For
End If
Next

If Weekday(NovaData) = 7 Then NovaData = NovaData + 2
If Weekday(NovaData) = 1 Then NovaData = NovaData + 1
if DCount(“*”,”tblAgenda”,”funcionário=” & NrFuncionario &” and # “ & NovaData & “# between dtinicio and dtfinal”)=0 then NovaData = NovaData + 1
If NovaData <> dataInformada Then NovaData = DataDisponivel(NovaData,nrFuncionario)
DataDisponivel = NovaData
End Function

Boa Noite Mestre Alexandre Neves

Me desculpe o transtorno meu amigo, tem horas que da vontade de chutar o pau da barraca só pra ver ela cair.
Resolveram alterar a funcionalidade para evitar que o funcionário venha a ficar as vezes até 5 dias sem aparecer na empresa contando com final de semana.
Nova Regra:
Se funcionario não tiver falta no Mês terá direita a Uma(1) Folga com direito a escolher a data
Então não teria mais a data inicio e data final e sim apenas uma data a incluir na tabela, de resto segue no mesmo critério do post nº 4.

Mas fazendo oque voce solicitou nesta linha deu erro de compilação, Mas acredito que agora deva ser alterada para nova funcionalidade
Como ficaria sem data inicio e data final?

if DCount(“*”,”tblAgenda”,”funcionário=” & NrFuncionario &” and # “ & NovaData & “# between dtinicio and dtfinal”)=0 then NovaData = NovaData + 1

Alexandre mais uma vez te peço desculpas

Abraços

Boa noite, Celso
Sem critério de datas ficará
if DCount(“*”,”tblAgenda”,”funcionário=” & NrFuncionario)=0 then NovaData = NovaData + 1
No entanto, o critério vai ser preciso senão bastará qeu o funcionário tenha 1 registo na agenda, em qualquer data para que nunca mais possa agendar nada.
Reveja como se poderá ter critério(s) que funcione para se implementar

Obrigado Alexandre

Consegui resolver com sua GRANDE ajuda,
Quanto aos critérios que voce mencionou criei um critério que verifica se funcionário cumpriu folga.
Se já então tranfere o registro para tblagendaExec e deleta agendamento da tblagenda

Agradeço por tua paciência e colaboração

Abraços