Calendario de Eventos (Adaptado com feriados brasileiros)

Exemplo postado pelo JPaulo, adaptado para deixar domingos e feriados em vermelho.


'Neste exemplo troque a função Cal(m, Y) por essa abaixo, ou somente acrescente a parte em vermelho

http://maximoaccess.forumeiros.com/t5481-calendario-de-eventos


Function Cal(m, Y)
Dim a
Dim DayOne
Dim gOffset
Dim f As Form
Dim h As Form
Dim workdate
Dim myDay As Integer
Dim diaDomingo As String
myDay = Format(Date, "dd")
'Adicionei

Set f = Forms!frmCalender

f!month.SetFocus
m = f!month
Y = f!year

For a = 1 To 37
f("Day" & a + gOffset).Visible = False
f("Text" & a + gOffset).Visible = False
f("horario" & a + gOffset).Visible = False
f("date" & a + gOffset) = Null
f("day" & a + gOffset) = Null
'Removido linha abaixo
'f("horario" & a + gOffset) = Null
Next

DayOne = DateValue("1/" & m & "/" & Y)
' DayOne = DateValue(m & "/1/" & Y)
workdate = DayOne
gOffset = Weekday(DayOne) - 1

For a = 1 To LenMonth(DayOne)
f("Day" & a + gOffset).Visible = True
f("Text" & a + gOffset).Visible = True
'f("horario" & a + gOffset).Visible = True
f("date" & a + gOffset) = workdate
workdate = workdate + 1
f("day" & a + gOffset) = a
If a = myDay Then
f("Text" & a + gOffset).BackColor = vbGreen 'RGB(255, 236, 139)
f("Day" & a + gOffset).BackColor = vbGreen 'RGB(255, 236, 139)
Else
f("Text" & a + gOffset).BackColor = vbWhite 'RGB(198, 226, 255)
f("Day" & a + gOffset).BackColor = vbWhite 'RGB(198, 226, 255)
End If

'Feriados em vermelho
If FeriadoBrasileiro(Format(workdate - 1, "dd-mm-yyyy"), SãoPaulo) = True Then
f("Day" & a + gOffset).ForeColor = vbRed
Else
f("Day" & a + gOffset).ForeColor = vbBlack
End If

'Adicionei para deixar em vermelho se domingo
If Format(workdate - 1, "dddd") = "domingo" Then
f("Day" & a + gOffset).ForeColor = vbRed
Else
End If
Next
Call PutInData

End Function


'Utilizar a função de Feriados do Grande alexandre http://maximoaccess.forumeiros.com/t971-feriados-brasileiros?highlight=feriados
'Salve o código abaixo em um novo módulo
Option Compare Database
Option Explicit

Enum NomeEstado
Acre = 1
Alagoas = 2
Amapá = 3
Amazonas = 4
Bahía = 5
Ceará = 6
DistritoFederal = 7
EspíritoSanto = 8
Goiás = 9
Maranhão = 10
MatoGrosso = 11
MatoGrossoDoSul = 12
MinasGerais = 13
Pará = 14
Paraíba = 15
Paraná = 16
Pernambuco = 17
Piauí = 18
RioDeJaneiro = 19
RioGrandeDoNorte = 20
RioGrandeDoSul = 21
Rondônia = 22
Roraima = 23
SantaCatarina = 24
SãoPaulo = 25
Sergipe = 26
Tocantins = 27
End Enum

Public Function PascoaB(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
PascoaB = DateSerial(intAno, 3, d + e + 22)
Else
PascoaB = DateSerial(intAno, 4, d + e - 9)
End If
If PascoaB = DateSerial(intAno, 4, 26) Then PascoaB = DateAdd("d", -7, PascoaB)
If PascoaB = DateSerial(intAno, 4, 25) And d = 28 And a > 10 Then PascoaB = DateAdd("d", -7, PascoaB)
End Function

Public Function FeriadoBrasileiro(dtData As Date, Optional strNomeEstado As NomeEstado) As Boolean
'criada por Alexandre Neves
'www.esnips.com\web\AlexandreNeves
FeriadoBrasileiro = False
Select Case Format(dtData, "dd-mm")
Case "01-01"
FeriadoBrasileiro = True
Case "21-04"
FeriadoBrasileiro = True
Case "01-05"
FeriadoBrasileiro = True
Case "07-09"
FeriadoBrasileiro = True
Case "12-10"
FeriadoBrasileiro = True
Case "02-11"
FeriadoBrasileiro = True
Case "15-11"
FeriadoBrasileiro = True
Case "25-12"
FeriadoBrasileiro = True
End Select

If dtData = DateAdd("d", -47, PascoaB(year(dtData))) Then FeriadoBrasileiro = True
If dtData = DateAdd("d", -2, PascoaB(year(dtData))) Then FeriadoBrasileiro = True
If dtData = PascoaB(year(dtData)) Then FeriadoBrasileiro = True
If dtData = DateAdd("d", 49, PascoaB(year(dtData))) Then FeriadoBrasileiro = True
If dtData = DateAdd("d", 56, PascoaB(year(dtData))) Then FeriadoBrasileiro = True
If dtData = DateAdd("d", 60, PascoaB(year(dtData))) Then FeriadoBrasileiro = True

If Not IsMissing(strNomeEstado) Then
Select Case strNomeEstado
Case Acre
If Format(dtData, "dd-mm") = "15-06" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "06-08" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "05-09" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "17-11" Then FeriadoBrasileiro = True
Case Alagoas
If Format(dtData, "dd-mm") = "24-06" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "29-06" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "16-09" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case Amapá
If Format(dtData, "dd-mm") = "19-03" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "05-10" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case Amazonas
If Format(dtData, "dd-mm") = "05-09" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "08-12" Then FeriadoBrasileiro = True
Case Bahía
If Format(dtData, "dd-mm") = "28-06" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "02-07" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case DistritoFederal
If Format(dtData, "dd-mm") = "21-04" Then FeriadoBrasileiro = True
Case EspíritoSanto
If Format(dtData, "dd-mm") = "23-05" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "28-10" Then FeriadoBrasileiro = True
Case Goiás
If Format(dtData, "dd-mm") = "26-07" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "28-10" Then FeriadoBrasileiro = True
Case Maranhão
If Format(dtData, "dd-mm") = "28-07" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "28-12" Then FeriadoBrasileiro = True
Case MatoGrosso
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case MatoGrossoDoSul
If Format(dtData, "dd-mm") = "11-10" Then FeriadoBrasileiro = True
Case Pará
If Format(dtData, "dd-mm") = "15-08" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "08-12" Then FeriadoBrasileiro = True
Case Paraíba
If Format(dtData, "dd-mm") = "05-08" Then FeriadoBrasileiro = True
Case Paraná
If Format(dtData, "dd-mm") = "08-09" Then FeriadoBrasileiro = True
Case Pernambuco
If Format(dtData, "dd-mm") = "06-03" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "24-06" Then FeriadoBrasileiro = True
Case Piauí
If Format(dtData, "dd-mm") = "13-03" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "19-10" Then FeriadoBrasileiro = True
Case RioDeJaneiro
If Format(dtData, "dd-mm") = "21-01" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "23-04" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "18-10" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "28-10" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case RioGrandeDoNorte
If Format(dtData, "dd-mm") = "29-06" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "03-10" Then FeriadoBrasileiro = True
Case RioGrandeDoSul
If Format(dtData, "dd-mm") = "20-09" Then FeriadoBrasileiro = True
Case Rondônia
If Format(dtData, "dd-mm") = "04-01" Then FeriadoBrasileiro = True
Case Roraima
If Format(dtData, "dd-mm") = "05-10" Then FeriadoBrasileiro = True
Case SantaCatarina
If Format(dtData, "dd-mm") = "11-08" Then FeriadoBrasileiro = True
Case SãoPaulo
If Format(dtData, "dd-mm") = "09-07" Then FeriadoBrasileiro = True
If Format(dtData, "dd-mm") = "20-11" Then FeriadoBrasileiro = True
Case Sergipe
If Format(dtData, "dd-mm") = "08-07" Then FeriadoBrasileiro = True
Case Tocantins
If Format(dtData, "dd-mm") = "05-10" Then FeriadoBrasileiro = True
End Select
End If
End Function

Esse campo é de meu bd, pois adicionei tambem um campo horário.
Retirei no código acima, tire de seu banco e teste.

Perfeito!

Ótima contribuição. Parabéns!

Abraço!