Verifica atraso na entrada de um funcionario

De autoria de Heio Candido, disponibilizado abertamente na rede:

'por: HELIO CANDIDO

'Função de minha autoria.

'OBS.: a rotina é um pouco extensa devido às mensagens que serão exibidas, mas se quizer é só
'tirar as mensagens. Mas a função é executada com muita velocidade.

'A função abaixo de minha autoria, faz verificação de hora conforme um horário que você
'especificar, tipo verifica se você chegou atrasado, adiantado ou no horário.

   'Para usá-la use o seguinte código, imaginando que o critério seja 08:00
       'VerificarAtraso "08:00", Time
       

Public Sub VerificarAtraso(HoraCriterio As String, HoraAtraso As String)

Dim MinutosAtraso As String
Dim MinutosCriterio As String
Dim CriterioMinutos As Integer
Dim AtrasoMinutos As Integer
Dim CriterioHoras As Integer
Dim AtrasoHoras As Integer
Dim TotalHoraAtraso As Integer
Const Minutos = 60
Dim AlterarAtrasoHoras As Integer
Dim AlterarAtrasoMinutos As Integer
Dim NovoAtrasoMinuto As Integer

'Atribui os valores dados pelo usuário
    MinutosAtraso = Minute(HoraAtraso)
    MinutosCriterio = Minute(HoraCriterio)

'Transforma os valores dados em números para que possam ser feitos os cálculos
   'Minutos
    CriterioMinutos = Int(MinutosCriterio)
    AtrasoMinutos = Int(MinutosAtraso)

   'Horas
    CriterioHoras = Int(Hour(HoraCriterio))
    AtrasoHoras = Int(Hour(HoraAtraso))

   'Verifica se o usuário chegou em cima da hora, se positivo, ele é pontual
    If AtrasoMinutos = CriterioMinutos Then
        MsgBox "Você é pontual, tenha um bom trabalho!!!", vbInformation, "Pontualidade OK..."
        Exit Sub
    End If

   'Faz a verificação para saber os minutos de atraso e as horas também
   
   'Se tiver a hora do usuário for igual a hora de critério então verifica apenas
   'os minutos
    If AtrasoHoras = CriterioHoras Then
        AlterarAtrasoMinutos = AtrasoMinutos - MinutosCriterio
        AtrasoMinutos = AlterarAtrasoMinutos
    End If

   'Se o usuário tiver chegado depois da hora, verifica as horas e os minutos para
   'executar os cálculos referentes
    If AtrasoHoras > CriterioHoras Then
       
       'Verifica se os minutos são iguais aos minutos de critério
       'Esse código só vale caso o usuário tenha informado como critério uma hora que
       'tenha minutos diferentes de 0 (zero).
        If AtrasoMinutos = 0 Then
            AlterarAtrasoMinutos = Minutos - CriterioMinutos
            AtrasoMinutos = AlterarAtrasoMinutos

            AlterarAtrasoHoras = AtrasoHoras - 1
            AtrasoHoras = AlterarAtrasoHoras
        Else
            If AtrasoMinutos > 0 Then
                AlterarAtrasoMinutos = AtrasoMinutos - CriterioMinutos
                NovoAtrasoMinuto = AlterarAtrasoMinutos

                If AlterarAtrasoMinutos >= 0 Then
                    AtrasoMinutos = AlterarAtrasoMinutos
                Else
                    If AlterarAtrasoMinutos < 0 Then
                        AlterarAtrasoMinutos = Minutos - CriterioMinutos
                        AlterarAtrasoMinutos = AlterarAtrasoMinutos + AtrasoMinutos
                        AtrasoMinutos = AlterarAtrasoMinutos

                        AlterarAtrasoHoras = AtrasoHoras - 1
                        AtrasoHoras = AlterarAtrasoHoras
                    End If
                End If
            End If
        End If
    End If

   'Aqui verifica a hora de atraso
    If AtrasoHoras > CriterioHoras Then
        TotalHoraAtraso = AtrasoHoras - CriterioHoras
    Else
        TotalHoraAtraso = AtrasoHoras - CriterioHoras
    End If

   'Caso a hora de atraso seja menor a hora de criterio então verifica também os
   'minutos
    If TotalHoraAtraso < 0 Then
       'Caso os minutos de atraso sejam menores que o minuto de critério então
       'o usuário chegou adiantado
        If AtrasoMinutos < 0 Then
            MsgBox "Você chegou adiantado, bom trabalho!!!", vbInformation, "Adiantado..."
            Exit Sub
        End If
    End If

    If TotalHoraAtraso < 0 Then
            MsgBox "Você chegou adiantado, bom trabalho!!!", vbInformation, "Adiantado..."
            Exit Sub
    End If

    If TotalHoraAtraso = 0 Then
        If AtrasoMinutos < 0 Then
            MsgBox "Você chegou adiantado, bom trabalho!!!", vbInformation, "Adiantado..."
            Exit Sub
        End If
    End If

   'Conforme os resultados anteriores exibe as referidas mensagens de maneira correta
    If TotalHoraAtraso <> 0 Then
        If TotalHoraAtraso > 1 And AtrasoMinutos > 1 Then
            MsgBox "Você chegou atrasado " & TotalHoraAtraso & " horas e " & AtrasoMinutos & " minutos!!!", vbInformation, "Atraso..."
        End If

        If TotalHoraAtraso > 1 And AtrasoMinutos <= 1 Then
            If AtrasoMinutos <> 0 Then
                MsgBox "Você chegou atrasado " & TotalHoraAtraso & " horas e " & AtrasoMinutos & " minuto!!!", vbInformation, "Atraso..."
            Else
                MsgBox "Você chegou atrasado " & TotalHoraAtraso & " horas!!!", vbInformation, "Atraso..."
            End If
        End If

        If TotalHoraAtraso <= 1 And AtrasoMinutos > 1 Then
            MsgBox "Você chegou atrasado " & TotalHoraAtraso & " hora e " & AtrasoMinutos & " minutos!!!", vbInformation, "Atraso..."
        End If

        If TotalHoraAtraso <= 1 And AtrasoMinutos <= 1 Then
            If AtrasoMinutos <> 0 Then
                MsgBox "Você chegou atrasado " & TotalHoraAtraso & " hora e " & AtrasoMinutos & " minuto!!!", vbInformation, "Atraso..."
            Else
                MsgBox "Você chegou atrasado " & TotalHoraAtraso & " hora!!!", vbInformation, "Atraso..."
            End If
        End If
    Else
        If AtrasoMinutos > 1 Then
            MsgBox "Você chegou atrasado " & AtrasoMinutos & " minutos!!!", vbInformation, "Atraso..."
        End If

        If AtrasoMinutos <= 1 Then
            MsgBox "Você chegou atrasado " & AtrasoMinutos & " minuto!!!", vbInformation, "Atraso..."
        End If
    End If

End Sub

Enjoy!!!

*****************************************************************************************************************



Repositório de Exemplos Ms Access
Sala destinada à colocação de exemplos em Ms Access (Código aberto) de e para
todos os Utilizadores Cadastrados.
Não tirar duvidas nesta sala.