Excel VBA [todas as versões] - Controle "Calendário" transponível

Novembro 2016



Introdução

No VBA, o controle de calendário mudou entre as versões do Excel 2003 e 2010. As versões mais antigas têm um controle chamado "Calendário", nas versões mais recentes, o controle é o DT Picker.
A preocupação com a transportabilidade das pastas criadas virou um problema. Como usar meu controle "Calendário" nas novas versões e, como usar o DT Picker nas antigas?

Outro problema é a instalação do seu pacote Office. Certas configurações de empresa não permitem o acesso ao controle DT Picker.

Para remediar esta situação, sugiro que você crie o seu próprio controle de "Calendário", utilizando um formulário de usuário.

O Formulário do Usuário (UserForm)

Ele deverá conter entre 29 e 31 botões de comando "Dias", um selo "Escolha do mês" e dois botões (">" e "<") para as mudanças de mês. O mês e o ano "em andamento" aparecerão no "Caption" (título) do userform. Todos os controles, dentro deste UserForm serão criados dinamicamente. Assim, você não precisará desenhá-los. Da mesma forma, o tamanho não tem importância, pois ele vai ser em função do número de botões e sua disposição no Calendário do UserForm.

No seu editor VBA, crie um novo formulário de usuário e altere a sua propriedade Name para Calendário.
Neste módulo de UserForm, coloque o seguinte código:

Option Explicit

Private Sub UserForm_Initialize()
Dom Obj As Control
Dom i As Integer, Mês As Integer, Ano As Integer
Dom Cl As Classe1

'Criação Mudança de mês
'LABEL
Set Collect = New Collection
Set Obj = Me.Controls.Add("forms.Label.1")
With Obj
    .Name = "LbEscolhaMês"
    .Object.Caption = "Escolha do mês: "
    .Left = 5
    .Top = 5
    .Width = 70
    .Height = 10
End With
'BOUTONS < e >
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "MoisPrec"
    .Object.Caption = "<"
    .Left = 75
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New Classe1
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "MoisSuiv"
    .Object.Caption = ">"
    .Left = 95
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New Classe1
Set Cl.Bouton = Obj
Collect.Add Cl

'Criação cabeçalho Dias da semana
For i = 1 To 7
    Set Obj = Me.Controls.Add("forms.Label.1")
    With Obj
        .Name = "Dia" & i
        .Object.Caption = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1))
        .Left = 20 * (i - 1) + 5
        .Top = 25
        .Width = 20
        .Height = 10
    End With
Next i

'Criação botões "Dias"
Mês = Month(Date)
MêsEmAndamento = Mês
Ano = Year(Date)
AnoEmAndamento = Ano
CriaçãoBotõesDias Mês, Ano
If Left(Format(Data, "dd"), 1) = "0" Then Me.Controls("Botão" & Formato(Date, "d")).SetFocus Else Me.Controls("Botão" & Formato(Data, "dd")).SetFocus
End Sub

Como criar botões

Comme nous ne connaissons pas, à la base, le nombre de boutons "Jours" à créer, nous allons les créer dynamiquement. Pour cela, il nous faut une procédure qui :
Como, em princípio, não sabemos o número de botões "Dias" a serem criados, vamos cria-los dinamicamente. Para isso, seguiremos um procedimento que:
  • exclua os antigos botões,
  • crie novos em função do mês e do ano.


Crie um Módulo (menu Inserir/Módulo) e entre este código:

Option Explicit

Public Collect As Collection, CollecBtnJours As Collection
Public MesEmAndamento As Integer, AnoEmAndamento As Integer

'Procedimento para criar botões Dias
'em função do ano e do mês "em andamento"
Sub CriaçãoBotõesDias (Mês As Integer, Ano As Integer)
Dom Obj As Control
Dom Cls As ClasseBtnJours
Dom NúmeroDias As Integer, T As Integer, Gauc As Integer, Coul As Long, i As Integer, Tamanho As Integer

'Remoção de todos os botões de comando "Dias"
For Each Obj In Calendrier.Controls
    If Left(Obj.Name, 6) = "Bouton" Then Calendrier.Controls.Remove Obj.Name
Next

'Criação de botões Dias em função do ano e do mês "em andamento"
Set CollecBtnJours = New Collection
NúmeroDias = Day(DateSerial(Ano, Mês + 1, 1) - 1)
For i = 1 To NúmeroDias
    If i = 1 Then T = 35
    Select Case UCase(Format(DateSerial(Ano, Mês, i), "dddd"))
        Case "SEGUNDA-FEIRA"
            Gauc = 0
            If i <> 1 Then T = T + 20
            Coul = 13037551
        Case "TERÇA-FEIRA"
            Gauc = 20
            Coul = 13037551
        Case "QUARTA-FEIRA"
            Gauc = 40
            Coul = 13037551
        Case "QUINTA-FEIRA"
            Gauc = 60
            Coul = 13037551
        Case "SEXTA-FEIRA"
            Gauc = 80
            Coul = 13037551
        Case "SÁBADO"
            Gauc = 100
            Coul = 3754751
        Case "DOMINGO"
            Gauc = 120
            Coul = 3754751
    End Select
    If EstJourFerie(DateSerial(Ano, Mês, i)) Or Paques(Ano = DateSerial(Ano, Mês, i) Then Coul = 1627780
    Set Obj = Calendrier.Controls.Add("forms.CommandButton.1")
    With Obj
        .Name = "Botão" & i
        .Object.Caption = i
        .Left = Gauc
        .Top = T
        .Width = 20
        .Height = 20
        .Object.BackColor = Coul
    End With
    If i = NúmeroDias Then Tamanho = Obj.Top + Obj.Height + 20
    Set Cls = New ClasseBtnJours
    Set Cls.Btn = Obj
    CollecBtnJours.Add Cls
Next i
With Calendrier
    .Caption = Format(DateSerial(AnneeEnCours, MoisEnCours, 1), "mmmm aaaa")
    .Tag = MoisEnCours & "/" & AnneeEnCours
    .Height = Taille
    .Width = 145
End With
End Sub

Os módulos de classe

Vamos precisar de dois módulos de classe para que os nossos botões de comando possam "agir."

A classe dos botões Anterior e Seguinte

Um módulo de classe (chamado: Classe1) que vai gerar os botoões "Anterior" et "Seguinte".

Option Explicit

Public WithEvents Bouton As MSForms.CommandButton

Private Sub Bouton_Click()
Select Case Bouton.Name
    Case "MêsAnterior"
        MêsEmCurso = MêsEmCurso - 1
        If MêsEmCurso = 0 Then
            MêsEmCurso = 12
            AnoEmCurso = AnoEmCurso - 1
            If AnoEmCurso = 1899 Then
                MêsEmCurso = 1
                AnoEmCurso = 1900
                MsgBox "Primeiro ano : 1900"
            End If
        End If
    Case "MêsSeguinte"
        MêsEmCurso = MêsEmCurso + 1
        If MêsEmCurso = 13 Then
            MêsEmCurso = 1
            AnoEmCurso = AnoEmCurso + 1
        End If
End Select
CriaçãoBotõesDias MêsEmCurso, AnoEmCurso
End Sub

A classe dos botões "Dias"

Um módulo de classe (chamado: ClasseBotoõesDias) que vai gerar os botões numerados dos dias.

Option Explicit

Public WithEvents Btn As MSForms.CommandButton

'Procedimento ao clicar no botão "Dia"
Private Sub Btn_Click()
Dom minhaData As Date

minhaData = CDate(Btn.Caption & "/" & Calendário.Tag)
 `A linha seguinte determina a ação a ser efetuada ao se clicar no botão 
     `Para introduzir a data selecionada em uma cela e fechar o formulário de usuário:
        'ActiveCell.Value = minhaData
        'Unload Calendário
MsgBox minhaData
End Sub

'Exibe o nome do dia feriado quando o mouse passa pelo botão
Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dom minhaData As Date

minhaData = CDate(Btn.Caption & "/" & Calendário.Tag)
If ÉDiaFeriado (minhaData) Or Páscoa(Year(minhaData)) = minhaData Then Btn.ControlTipText = QueFeriado(minhaData)
End Sub

As funções "Dias Feriados"

No Módulo padrão criado anteriormente, vamos adicionar três funções. Elas nos permitirão identificar os dias feriados. Duas não são minhas, as fontes foram citadas no código.

Função que transforma o dia feriado em "String"

'Função que transforma o dia feriado em "String"   
dicas úteis para quando passar o mouse sobre os dias feriados 
Public Function QueFeriado(Dia As Date) As String
Dom minhaData As Date
Dom a As Integer, m As Integer, j As Integer

minhaData = Páscoa(Year(Dia))
If Dia = minhaData Then QueFeriado = "Domingo de Páscoa": Exit Function
If Dia = CDate(minhaData + 1) Then QueFeriado = "Sexta-Feira da Paixão": Exit Function
If Dia = CDate(minhaData + 50) Then QueFeriado = "Segunda de Pentecostes": Exit Function
If Dia = CDate(minhaData + 39) Then QueFeriado = "Quinta da Ascenção": Exit Function

a = Year(Dia): m = Month(Dia): j = Day(Dia)
Select Case m * 100 + j
  Case 101
    QueFeriado = "1° de Janeiro": Exit Function
  Case 501
    QueFeriado = "22de Abril": Exit Function
  Case 508
    QueFeriado = "1° de Maio ": Exit Function
  Case 714
    QueFeriado = "7 de Setembro": Exit Function
  Case 815
    QueFeriado = "15 de Outubro": Exit Function
  Case 1101
    QueFeriado = "1° de Novembro": Exit Function
  Case 1111
    QueFeriado = "15 de  Novembro": Exit Function
  Case 1225
    QueFeriado = "Natal": Exit Function
End Select
End Function

Função que identifica os dias feriados

Public Function ÉDiaFeriado(ByVal laDate As Date, Optional ByVal PentecostesÉFeriado As Boolean = True) As Boolean
'Determine se a data passada em argumento é um dia feriado ou não:
'   101 = 1° de Janeiro - 501 = 22 de Abril - 508 = 1° de Maio - 714 = 7 de Setembro
'   815 = 15 de Outubro - 1101 = 1° de Novembro - 1111 = 15 de Novembro - 1225 = 25 de Dezembro
'   dPa = sexta-feira da Paixão - dAs = quinta-feira da Ascensão - dPe = segunda-feira de Pentecostes
Observação : A segunda-feira de Pentecostes não é feriado 
(PentecostesEFeriado= False neste caso)
'Philben - v1.0 - 2012 - Free to use
  Static Annee As Integer, dPa As Date, dAs As Date, dPe As Date, bPe As Boolean
   Dom a As Integer, m As Integer, j As Integer

   a = Year(aData): m = Month(aData): j = Day(aData)
   Select Case m * 100 + j
   Case 101, 501, 508, 714, 815, 1101, 1111, 1225
      ÉDiaFeriado = True
   Case 323 To 614   '323: Data mínima Quinta-feira da Paixão - 614 : Data máxima Segunda -feira de Pentecostes
     If a <> Ano Or PentecostesEFeriado <> bPe Then
         Ano = a: dPa = Pascoa(a) + 1: dAs = dPa + 38
         bPe = PentecostesEFeriado: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100#
      End If
      Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: ÉDiaFeriado = True: End Select
   End Select
End Function

Função Domingo de Páscoa

Public Function Pascoa(ByVal an As Integer) As Date
'Cálculo da data do domingo de Páscoa a partir do ano 325
`Desempenho por milhão de chamadas:
'   - Entre 325 e 1582 e entre 1900 e2099   => 1/4 de segundo
'   - Ano superior a 1582 fora 1900 - 2099 => 1/2 de segundo
'Philben - v1.0 - Free to use
  Dom a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer
   If an < 10000 Then    'Limite superior das datas no Access (31 de dezembro de 9999)
     Select Case an
      Case 1900 To 2099    'Algoritmo de Carter
        a = (204 - 11 * (an Mod 19)) Mod 30 + 22
         Páscoa = DateSerial(an, 3, a + 6 + (a > 49) - (ano + ano \ 4 + a + (a > 49)) Mod 7)
      Case Is > 1582    'Proposto em 1876 na revista Nature (derivado do algoritmo de Delambre)
        a = ano Mod 19: b = ano \ 100: c = ano Mod 100
         d = (19 * a + b - b \ 4 - (b - (b + 8) \ 25 + 1) \ 3 + 15) Mod 30
         e = (32 + 2 * (b Mod 4) + 2 * (c \ 4) - d - c Mod 4) Mod 7
         f = d + e - 7 * ((a + 11 * d + 22 * e) \ 451) + 114
         Páscoa = DateSerial(an, f \ 31, f Mod 31 + 1)
      Case Is > 324    'Algoritmo de Oudin para as datas de julho < 1583 descrito por Claus Tondering
        a = (19 * (an Mod 19) + 15) Mod 30
         Páscoa = DateSerial(an, 3, 28 + a - (an + an \ 4 + a) Mod 7)
      End Select
   End If
End Function

Download

Veja a Planilha exemplo, no formato .xls (em francês).

Tradução feita por Lucia Maurity y Nouira

Veja também :
Este documento, intitulado « Excel VBA [todas as versões] - Controle "Calendário" transponível »a partir de CCM (br.ccm.net) está disponibilizado sob a licença Creative Commons. Você pode copiar, modificar cópias desta página, nas condições estipuladas pela licença, como esta nota aparece claramente.