[Resolvido]Aplicar cores em Sábados, Domingos e Feriados em Calendário

Em solicitação do colega Assis, solução para aplicação de cores nos rótulos dos dias da semana que caem no sábdo, domingo ou feriado.

Código:

Private Function fctnPopulate()
On Error Resume Next
' Populate and format the calendar labels grid
Dim datIn As Date ' Date variable to be set as the first day of the displayed month
Dim bytLab As Byte ' Byte variable to be set as the day of the week the first of the month is on
Dim ctl As Control ' Control object allows calendar grid controls to be looped through
Dim strLab As String ' String variable used to isolate the numeric portion of a calendar grid control's name
Dim datOut As Date ' Date variable set and written out to the calendar grid controls
datIn = Format(labDat.Caption, "dd-mmm-yyyy") ' Set to the first of the displayed month
bytLab = Weekday(datIn, vbMonday) ' Determine which day of the week the first of the month is on
For Each ctl In Me.Controls ' Loop through all the controls on the form
    If ctl.Tag = 1 Then ' All 42 of the calendar grid date labels have a Tag value of 1
        strLab = Mid$(ctl.Name, 4) ' Works out with date label is being used, i.e. control lab35 returns strLab="35"
        datOut = datIn + (CInt(strLab) - bytLab) ' Use datIn and offset from first day of the month control to set value of datOut
        ctl.Caption = Format(datOut, "dd") ' Set the control's caption to the date portion of datOut
        ctl.BorderStyle = -1 * (datOut = Date) 'If today's date then border in red
        ctl.BackColor = 16777215 + (255 * (datOut = datArg)) ' Background is grey if default date, otherwise white
    If left$(ctl.Caption, 1) = "0" Then ctl.Caption = Mid$(ctl.Caption, 2) ' Remove leading zeros, so 01 becomes 1
    If Format(datIn, "mm") = Format(datOut, "mm") Then ' If control's date value is in the displayed month
        ctl.ForeColor = 0 ' Text is black
    Else ' Tail-end of previous month or beginning of next
        ctl.ForeColor = 8421504 ' Text is dark grey
End If
End If
'---------------------------------------------------------------------------------------------------------------------
'Adaptação para colorir sábados, domingos e feriados
    'Aplica a cor nos sábados e domingos
    If ctl.Caption = ">" Or ctl.Caption = ">>" Or ctl.Caption = "<" Or ctl.Caption = "<<" Then GoTo Continuar
    If Weekday(datOut) = 1 Then  'Aplico a condição para checar se a data é domingo
            ctl.BackColor = vbRed    'Aplico a cor nos rótulos
            ctl.FontBold = True    'Aplico negrito nos rõtulos
    ElseIf Weekday(datOut) = 7 Then  'Aplico a condição para checar s e data é sábado
            ctl.BackColor = vbYellow 'Aplico a cor nos rõtulos
            ctl.FontBold = True    'Aplico negrito nos rótulos
    End If
    'Checa se a data é feriado
    If Feriado(datOut) Then
           ctl.BackColor = 12903679  'Aplico a cor nos rõtulos
           ctl.FontBold = True    'Aplico negrito nos rótulos
    End If
Continuar:
'---------------------------------------------------------------------------------------------------------------------

Next ctl ' Do the loop
End Function

Cumprimentos.