Folha de Ponto com Sábados, Domingos e Feriados preenchidos automaticamente

Bem amigos, tenho estado afastado do forum por algum tempo devido a motivos de ordem pessoal.. No entanto hoje precisei fazer este trabalho e compartilho com o fórum.

Utilizando a função de feriados brasileiros do Grande Alexandre e um Data Pcker, preencho um relatorio de ponto, onde nos respectivos dias (Sábados, Domingos e Feriados) o label é preenchido com o texto referente.. mudando a cada mes de acordo com a oscilação dos mesmos.


LINK MDB


http://dl.dropbox.com/u/26441349/SYSPEN.rar

Saudações a todos do fórum e até a próxima....

Obrigado pelo exemplo, muito interessante..

Boas amigos... eis o mesmo trabalho, sem a utiloização do PickList (calendário)

No modelo anterior eu retirava os sabados e domingos do calendário através de carregar uma variãvel com o respectivo dia referente..


Dom1 = Forsm!NomedoForm......

LINK MDB http://dl.dropbox.com/u/26441349/FolhaPonto.rar

Agora utilizo uma função dentro do proprio relatorio para conseguir isto, esis o codigo completo.

Tambem efetua a diminuiçao do tamanho de linhas do form para dias que tem 28, 29 0u trinta dias.
para que nesses dias não aparecam as linha dos dias nao existentes.

Código:

Private Sub Report_Open(Cancel As Integer)
On Error GoTo TrataErro
Dim I As Double

'Adiciona a data do Documento
Me.txtData.Caption = Format(Date, "mmmm/yyyy")

'**********************************************************************************************************
'Funções de calendário para preenchimento de sábados e domingos no relatório
' Harysohn Pina - para Fórum Máximo Access (Maio/2012)
'----------------------------------------------------------------------------------------------------------

' Variáveis para a função
Dim D, S As String
Dim UltimoDia As Date
Dim UltimoDiaX As Integer
Dim DataMes, datax, Fer, DiaF As String
Dim DataN As Date
Dim DataIni As Date
Dim DataFin As Date
Dim X, N, M As Integer

' Aplica na variável DataMes o número do mes corrente, para utilização no codigos seguintes
DataMes = Format(Date, "mm")

'Carrega as Variáveis com a texto do final de semana
D = "DOMINGO"
S = "SÁBADO"
'Carreha as Variáveis com o texto para os rotulos em branco quando o mes contiver 29 ou 30 dias



   
    'Encontro o último dia do mês
    UltimoDia = DateAdd("m", 1, DateSerial(Year(Date), Month(Date), 1))
    UltimoDia = DateAdd("d", -1, UltimoDia)
    UltimoDia = Format(UltimoDia, "mm/dd/yyyy")
    UltimoDiaX = Format(UltimoDia, "dd")
   
'===============================================================================================================
'Esconde Rótulos, Linhas e diminui Caixa texto para quando o mes tiver 29 dias
'em conformidade com o mês corrente
If UltimoDiaX = 28 Then
            For I = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra XXXXXXXXXX no mesmo
                    Me("lb" & 29).Visible = False
                    Me("lb" & 30).Visible = False
                    Me("lb" & 31).Visible = False
                    Me("lb" & 29 & "_" & I).Visible = False
                    Me("lb" & 30 & "_" & I).Visible = False
                    Me("lb" & 31 & "_" & I).Visible = False
                        For M = 29 To 31
                            Me("lb" & M & "_" & I & "A").Visible = False
                            Me("lb" & M & "_" & I & "B").Visible = False
                            Me("lb" & M & "_" & I & "C").Visible = False
                            Me("lb" & M & "_" & I & "D").Visible = False
                        Next M
                    Me.L1.Visible = False
                    Me.L2.Visible = False
                    Me.L3.Visible = False
                    Me.Cx1.Height = 6960
                    For M = 1 To 4
                        Me("LV" & M).Height = 6410
                    Next M
                    For M = 1 To 6
                        Me("LZ" & M).Height = 6950
                    Next M
                   
            Next I
           
ElseIf UltimoDiaX = 29 Then
            For I = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra XXXXXXXXXX no mesmo
                    Me("lb" & 30).Visible = False
                    Me("lb" & 31).Visible = False
                    Me("lb" & 30 & "_" & I).Visible = False
                    Me("lb" & 31 & "_" & I).Visible = False
                        For M = 30 To 31
                            Me("lb" & M & "_" & I & "A").Visible = False
                            Me("lb" & M & "_" & I & "B").Visible = False
                            Me("lb" & M & "_" & I & "C").Visible = False
                            Me("lb" & M & "_" & I & "D").Visible = False
                        Next M
                    Me.L2.Visible = False
                    Me.L3.Visible = False
                    Me.Cx1.Height = 7170
                    For M = 1 To 4
                        Me("LV" & M).Height = 6620
                    Next M
                    For M = 1 To 6
                        Me("LZ" & M).Height = 7180
                    Next M
                   
            Next I
           
ElseIf UltimoDiaX = 30 Then
            For I = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra XXXXXXXXXX no mesmo
                    Me("lb" & 31).Visible = False
                    Me("lb" & 31 & "_" & I).Visible = False
                    Me("lb" & 31 & "_" & I & "A").Visible = False
                    Me("lb" & 31 & "_" & I & "B").Visible = False
                    Me("lb" & 31 & "_" & I & "C").Visible = False
                    Me("lb" & 31 & "_" & I & "D").Visible = False
                    Me.L3.Visible = False
                    Me.Cx1.Height = 7400
                    For M = 1 To 4
                        Me("LV" & M).Height = 6850
                    Next M
                    For M = 1 To 6
                        Me("LZ" & M).Height = 7400
                    Next M
                   
            Next I


End If
'Final da configuracao de linhas e caixas texto =============================================================


        For I = 1 To UltimoDiaX ' Utilizo o recurso For para especificar o loop pelo numero de dias do mês
            Me("lb" & I).Caption = I 'Preencho a primeira coluna de rótulos, com os dias
        Next I
       
'==================================================================
'Função para Sabados e Domingos

'Preencho na variável do tipo string, o primeiro dia do mês, concatenando os vaores 1, Variável DataMes e o ano corrente
DataIni = CDate(1 & "/" & DataMes & "/" & Format(Date, "yyyy"))
'Pego último dia do mês e preencho na variável do tipo string, o data completa do último dia do mês
DataFin = CDate(UltimoDiaX & "/" & DataMes & "/" & Format(Date, "yyyy"))

'Faço um loop pelo numero de dias do mês para checar quais dias são sábados ou domingos
        For X = 1 To UltimoDiaX
            datax = X & "/" & DataMes & "/" & Format(Date, "yyyy")  'Aplico a data em uma string concatenando valores de texto, variãvel e ano corrente
            DataN = CDate(datax) ' Converto a string em data

        If Weekday(datax) = 1 Then  ' Aplico a condição para checar se a data é domingo, observe que a seguir vai mudando o rõtulo de acordo com o valor em X
            Me("lb" & X).BackColor = vbRed    'Aplico a cor nos rótulos
            Me("lb" & X).FontBold = True    'Aplico negrito nos rõtulos
                For I = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra Domingo no mesmo
                    Me("lb" & X & "_" & I).Caption = D
                Next
        ElseIf Weekday(datax) = 7 Then
            Me("lb" & X).BackColor = vbYellow 'Aplico a cor nos rõtulos
            Me("lb" & X).FontBold = True    'Aplico negrito nos rótulos
                For I = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra Sábado no mesmo
                    Me("lb" & X & "_" & I).Caption = S
                Next
        End If

        Next X
   
 
'========================================================================================================================================================================
' Preenchimentos de Feriados Brasileiros
Fer = "FERIADO"


        For X = 1 To UltimoDiaX ' Aplico o loop nos dias do mês
            datax = X & "/" & DataMes & "/" & Format(Date, "yyyy") 'Aplico a data em uma string concatenando valores de texto, variãvel e ano corrente
            DataN = CDate(datax) ' Converto a string em data
            If FeriadoBrasileiro(DataN, Goiás) = True Then ' Aplico a função de FeriadosBrasileiros, observando que vai checando a dataN, que é alterada a cada loop
            DiaF = Format(DataN, "d")  'Aqui pego o dia da data que foi encontrado feriado para preencher o respectivo rótulo
                For N = 1 To 9 ' Faço o loop nos rótulos de uma linha para aplicar a palavra Sábado no mesmo
                    'Esta condição é utilizada para em caso do feriado cair no sábado ou domingo, este não ser substituido pela palavra Feriado
                    If Me("lb" & X & "_" & N).Caption = "DOMINGO" Or Me("lb" & X & "_" & N).Caption = "DOMINGO" Then GoTo Continuar 'Remeto o codigo ao comando continuar
                    'Caso o feriado nao caia no sábado ou domingo, preencho o rótulo com o texto "Feriado"
                    Me("lb" & X & "_" & N).Caption = Fer
Continuar:
                 
                Next N
            Else
            End If
        Next X
     
'========================================================================================================================================================================


Exit Sub

TrataErro:
If err.Number = 2465 Then
    Resume Next
Else
    MsgBox Error, , "Erro nº" & err & " em Report Open"
End If

End Sub