MaximoAccess

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

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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

    Funções úteis

    Alexandre Neves
    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7780
    Registrado : 05/11/2009

    Funções úteis Empty Funções úteis

    Mensagem  Alexandre Neves em 5/10/2010, 15:02

    Lembrei-me de divulgar algumas funções que criei e me facilitam a construção de códigos:

    Arredonda valor conforme múltiplo de arredondamento pretendido
    Function Arredonda(varValor, MultiploDeArredondamento As Integer, varDevolvidaSeNulo As VbVarType)
    'Criada por Alexandre Neves - www.esnips.com/web/AlexandreNeves
    If IsNull(varValor) Then
    Select Case varDevolvidaSeNulo
    Case vbBoolean
    Arredonda = 0
    Case vbDouble
    Arredonda = 0
    Case vbInteger
    Arredonda = 0
    Case vbLong
    Arredonda = 0
    Case vbNull
    Arredonda = Null
    Case vbSingle
    Arredonda = 0
    Case vbString
    Arredonda = ""
    End Select
    Else
    If varValor Mod MultiploDeArredondamento = 0 Then
    Arredonda = varValor
    Else
    Arredonda = (Int(varValor / MultiploDeArredondamento) + 1) * MultiploDeArredondamento
    End If
    End If
    End Function

    Exemplo de utilização: PNTxtValor = Arredonda(SSe(PNTxtEM, vbDouble, vbNull), 100, vbNull)

    Procura valor de campo em tabela e devolve o valor. Se for nulo, devolve resultado conforme o tipo de dados escolhido
    Function ProcNulo(strCampo As String, strTabela As String, strCriterio As String, varDevolvida As VbVarType, varDevolvidaSeNulo As VbVarType, Optional varDevolvidasSeBoleanoZero As VbVarType)
    'Criada por Alexandre Neves - www.esnips.com/web/AlexandreNeves
    If IsNull(DLookup(strCampo, strTabela, strCriterio)) Then
    Select Case varDevolvidaSeNulo
    Case vbBoolean
    ProcNulo = 0
    Case vbDouble
    ProcNulo = 0
    Case vbInteger
    ProcNulo = 0
    Case vbLong
    ProcNulo = 0
    Case vbNull
    ProcNulo = Null
    Case vbSingle
    ProcNulo = 0
    Case vbString
    ProcNulo = ""
    End Select
    Else
    Select Case varDevolvida
    Case vbBoolean
    ProcNulo = DLookup(strCampo, strTabela, strCriterio)
    If ProcNulo = 0 And Not IsMissing(varDevolvidasSeBoleanoZero) Then
    Select Case varDevolvidasSeBoleanoZero
    Case vbNull
    ProcNulo = Null
    Case Else
    End Select
    End If
    Case vbDouble
    ProcNulo = CDbl(DLookup(strCampo, strTabela, strCriterio))
    Case vbInteger
    ProcNulo = CInt(DLookup(strCampo, strTabela, strCriterio))
    Case vbLong
    ProcNulo = CLng(DLookup(strCampo, strTabela, strCriterio))
    Case vbNull
    ProcNulo = Null
    Case vbSingle
    ProcNulo = CSng(DLookup(strCampo, strTabela, strCriterio))
    Case vbString
    ProcNulo = CStr(DLookup(strCampo, strTabela, strCriterio))
    Case vbDate
    ProcNulo = CDate(DLookup(strCampo, strTabela, strCriterio))
    End Select
    End If
    End Function

    Exemplo de utilização: IMRtlLocalidade.Caption = ProcNulo("Freguesia", "Localidades", "Codigo='" & IMCxcLocalidade & "'", vbString, vbString) & " - " & ProcNulo("Concelho", "Localidades", "Codigo='" & IMCxcLocalidade & "'", vbString, vbString) & " - " & ProcNulo("Distrito", "Localidades", "Codigo='" & IMCxcLocalidade & "'", vbString, vbString)


    Para que um controlo no formulário assuma o valor de outro controlo. Se for nulo, devolve resultado conforme tipo de dados pretendido:

    Function SSe(varDado, varDevolvida As VbVarType, varDevolvidaSeNulo As VbVarType)
    'Criada por Alexandre Neves - www.esnips.com/web/AlexandreNeves
    If IsNull(varDado) Then
    Select Case varDevolvidaSeNulo
    Case vbBoolean
    SSe = 0
    Case vbDouble
    SSe = 0
    Case vbInteger
    SSe = 0
    Case vbLong
    SSe = 0
    Case vbNull
    SSe = Null
    Case vbSingle
    SSe = 0
    Case vbString
    SSe = ""
    End Select
    Else
    Select Case varDevolvida
    Case vbBoolean
    SSe = 0
    Case vbDouble
    SSe = CDbl(varDado)
    Case vbInteger
    SSe = CInt(varDado)
    Case vbLong
    SSe = CLng(varDado)
    Case vbNull
    SSe = Null
    Case vbSingle
    SSe = CSng(varDado)
    Case vbString
    SSe = CStr(varDado)
    End Select
    End If
    End Function

    Exemplo de utilização: PNTxtAnual = SSe(PNTxtSemanal * 52, vbLong, vbNull)

    Funções de datas comummente utilizadas

    Function Carnaval(intAno As Integer) As Date
    Carnaval = DateAdd("d", -47, Pascoa(intAno))
    End Function

    Function CorpoDeDeus(ByVal intAno As Integer) As Date
    CorpoDeDeus = DateAdd("d", 60, Pascoa(intAno))
    End Function


    Function Feriado(ByVal DataAValidar As Date, FeriadoSemTrabalho As Boolean, Optional ByVal codigolocalidade As String) As Boolean
    'feriados nacionais
    If Format(DataAValidar, "dd-mm") = 1 / 1 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 25 / 4 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 5 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 10 / 6 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 15 / 8 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 5 / 10 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 11 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 12 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 8 / 12 Then
    Feriado = True
    ElseIf Format(DataAValidar, "dd-mm") = 25 / 12 Then
    Feriado = True
    ElseIf Carnaval(Year(DataAValidar)) = DataAValidar Then
    Feriado = True
    ElseIf SextaFeiraSanta(Year(DataAValidar)) = DataAValidar Then
    Feriado = True
    ElseIf Pascoa(Year(DataAValidar)) = DataAValidar Then
    Feriado = True
    ElseIf Pentecostes(Year(DataAValidar)) = DataAValidar Then
    If Not FeriadoSemTrabalho Then Feriado = True
    ElseIf SantissimaTrindade(Year(DataAValidar)) = DataAValidar Then
    If Not FeriadoSemTrabalho Then Feriado = True
    ElseIf CorpoDeDeus(Year(DataAValidar)) = DataAValidar Then
    Feriado = True
    End If
    End Function


    Function NomeFeriado(ByVal DataAValidar As Date) As String
    If Format(DataAValidar, "dd-mm") = 1 / 1 Then
    NomeFeriado = "Ano Novo"
    ElseIf Format(DataAValidar, "dd-mm") = 25 / 4 Then
    NomeFeriado = "Dia da Liberdade"
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 5 Then
    NomeFeriado = "Dia do Trabalhador"
    ElseIf Format(DataAValidar, "dd-mm") = 10 / 6 Then
    NomeFeriado = "Dia de Portugal"
    ElseIf Format(DataAValidar, "dd-mm") = 15 / 8 Then
    NomeFeriado = "Ascensão de Nossa Senhora"
    ElseIf Format(DataAValidar, "dd-mm") = 5 / 10 Then
    NomeFeriado = "Implantação da República"
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 11 Then
    NomeFeriado = "Todos os Santos"
    ElseIf Format(DataAValidar, "dd-mm") = 1 / 12 Then
    NomeFeriado = "Restauração da Independência"
    ElseIf Format(DataAValidar, "dd-mm") = 8 / 12 Then
    NomeFeriado = "Imaculada Conceição"
    ElseIf Format(DataAValidar, "dd-mm") = 25 / 12 Then
    NomeFeriado = "Natal"
    ElseIf Carnaval(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Carnaval"
    ElseIf SextaFeiraSanta(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Sexta-Feira Santa"
    ElseIf Pascoa(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Páscoa"
    ElseIf Pentecostes(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Pentecostes"
    ElseIf SantissimaTrindade(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Santíssima Trindade"
    ElseIf CorpoDeDeus(Year(DataAValidar)) = DataAValidar Then
    NomeFeriado = "Corpo de Deus"
    End If
    End Function

    Function Pascoa(intAno As Integer) As Date
    Dim X As Byte, Y As Byte
    Dim a As Byte, B As Byte, c As Byte, d As Byte, e As Byte

    If intAno > 1581 And intAno < 1600 Then X = 22: Y = 2
    If intAno > 1599 And intAno < 1700 Then X = 22: Y = 2
    If intAno > 1699 And intAno < 1800 Then X = 23: Y = 3
    If intAno > 1799 And intAno < 1900 Then X = 23: Y = 4
    If intAno > 1899 And intAno < 2000 Then X = 24: Y = 5
    If intAno > 1999 And intAno < 2100 Then X = 24: Y = 5
    If intAno > 2099 And intAno < 2200 Then X = 24: Y = 6
    If intAno > 2199 And intAno < 2300 Then X = 25: Y = 7

    a = intAno Mod 19
    B = intAno Mod 4
    c = intAno Mod 7
    d = ((19 * a) + X) Mod 30
    e = ((2 * B) + (4 * c) + (6 * d) + Y) Mod 7
    If (d + e) < 10 Then
    Pascoa = DateSerial(intAno, 3, d + e + 22)
    Else
    Pascoa = DateSerial(intAno, 4, d + e - 9)
    End If
    If Pascoa = DateSerial(intAno, 4, 26) Then Pascoa = DateAdd("d", -7, Pascoa)
    If Pascoa = DateSerial(intAno, 4, 25) And d = 28 And a > 10 Then Pascoa = DateAdd("d", -7, Pascoa)
    End Function

    Function Pentecostes(ByVal intAno As Integer) As Date
    Pentecostes = DateAdd("d", 49, Pascoa(intAno))
    End Function

    Function SantissimaTrindade(ByVal intAno As Integer) As Date
    SantissimaTrindade = DateAdd("d", 56, Pascoa(intAno))
    End Function

    Function SextaFeiraSanta(ByVal intAno As Integer) As Date
    SextaFeiraSanta = DateAdd("d", -2, Pascoa(intAno))
    End Function

      Data/hora atual: 28/11/2020, 02:34