MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

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

    Compartilhe
    avatar
    HARYSOHN
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 12233
    Registrado : 01/03/2011

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

    Mensagem  HARYSOHN em Qua 02 Maio 2012, 16:04

    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


    [Você precisa estar registrado e conectado para ver este link.]

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


    .................................................................................
    PILOTO
    الله أكبر Paz, Justiça e Liberdade! الله أكبر
    [Você precisa estar registrado e conectado para ver este link.]

    Iniciando no Access? Então veja esse [Você precisa estar registrado e conectado para ver este link.] e também [Você precisa estar registrado e conectado para ver este link.]


    [Você precisa estar registrado e conectado para ver este link.]

    Quando tua dúvida for RESOLVIDA, dê retorno com AGRADECIMENTO a aqueles que gastaram seu tempo em te ajudar.
    Clique no botão Resolvido logo acima do botão Enviar, do lado direito. Todos nós agradecemos.  
    [Você precisa estar registrado e conectado para ver esta imagem.]
    avatar
    Fernando Bueno
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1889
    Registrado : 13/04/2012

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

    Mensagem  Fernando Bueno em Qui 03 Maio 2012, 23:25

    Obrigado pelo exemplo, muito interessante..
    avatar
    HARYSOHN
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 12233
    Registrado : 01/03/2011

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

    Mensagem  HARYSOHN em Sex 11 Maio 2012, 13:26

    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 [Você precisa estar registrado e conectado para ver este link.]

    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


    .................................................................................
    PILOTO
    الله أكبر Paz, Justiça e Liberdade! الله أكبر
    [Você precisa estar registrado e conectado para ver este link.]

    Iniciando no Access? Então veja esse [Você precisa estar registrado e conectado para ver este link.] e também [Você precisa estar registrado e conectado para ver este link.]


    [Você precisa estar registrado e conectado para ver este link.]

    Quando tua dúvida for RESOLVIDA, dê retorno com AGRADECIMENTO a aqueles que gastaram seu tempo em te ajudar.
    Clique no botão Resolvido logo acima do botão Enviar, do lado direito. Todos nós agradecemos.  
    [Você precisa estar registrado e conectado para ver esta imagem.]

      Data/hora atual: Sab 21 Out 2017, 11:19