Funções úteis

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