XL 2016 [RESOLU] Traduction code VBA (code trouvé sur internet je ne comprend rien)

V

VBgalère

XLDnaute Nouveau
Bonjour, je fais un poste aujourd'hui car j'ai récupéré un code pour un calendrier sur internet que je ne comprends pas mais qui me serai d'une grande utilité.
Y aurait-il parmi nous des expert vba qui pourrait me faire une traduction? Merci d'avance pour votre aide.

VB: 
Option Explicit
Option Base 1

Dim Charge As Boolean
Dim OldAn As Integer, OldMois As Integer, Décalage As Integer
Dim OldDate As String
Dim EvitSub As Boolean
Public Function Chargement(Optional Mydate As String = "", Optional Pose As String = "0;0") As String

Dim t

OldDate = Mydate
t = Split(Pose, ";")
Me.Top = t(0): Me.Left = t(1)
If Mydate <> "" And Mydate <> "?" Then Me.Tag = Mydate Else Me.Tag = Date

EvitSub = True
    CBox_Mois.ListIndex = Mid$(Me.Tag, 4, 2) - 1: OldMois = CBox_Mois.ListIndex
    CBox_An.ListIndex = Right$(Me.Tag, 4) - 1950: OldAn = CBox_An.ListIndex
EvitSub = False

MajControle
Me.Show vbModal
On Error Resume Next
Chargement = Me.Tag
Unload Me

End Function
Sub MajControle()

Dim laDate As Date
Dim j As Integer
Dim m As Integer
Dim trouve As Boolean
Dim i  As Integer

Charge = False
laDate = CDate("01/" & Format(Me.Tag, "mm/yyyy"))
j = Weekday(laDate)

For i = 1 To 42
    m = i Mod 7
    Me.Controls("D" & i).Caption = ""
    Me.Controls("D" & i).Tag = ""
    Me.Controls("D" & i).SpecialEffect = fmSpecialEffectRaised
    If j = m + 1 And Not trouve Then
        trouve = True
        Me.Controls("D" & i).Enabled = True
        Me.Controls("D" & i).Caption = Format(laDate, "dd")
        Me.Controls("D" & i).Tag = laDate
    Else
        If i > 1 Then
            If Me.Controls("D" & i - 1).Tag = "" Then
                Me.Controls("D" & i).Enabled = False
            Else
                Me.Controls("D" & i).Caption = Format(CDate(Me.Controls("D" & i - 1).Tag) + 1, "dd")
                Me.Controls("D" & i).Tag = CDate(Me.Controls("D" & i - 1).Tag) + 1
                Me.Controls("D" & i).Enabled = True
            End If
        Else
            Me.Controls("D" & i).Enabled = False
        End If
    End If

    If Me.Controls("D" & i).Tag <> "" Then
        If Month(CDate(Me.Controls("D" & i).Tag)) <> Month(Me.Tag) Then
            Me.Controls("D" & i).Caption = ""
            Me.Controls("D" & i).Tag = ""
            Me.Controls("D" & i).Enabled = False
        End If
    End If

    If Me.Controls("D" & i).Tag <> "" Then
        If CDate(Me.Controls("D" & i).Tag) = CDate(Me.Tag) Then
            Me.Controls("D" & i).SpecialEffect = fmSpecialEffectSunken
       Else
            Me.Controls("D" & i).SpecialEffect = fmSpecialEffectRaised
       End If
    End If
Next

Charge = True

End Sub
Private Sub Cmd_CeJour_Click()

Me.Tag = Date: Me.Hide

End Sub
Private Sub Cmd_Echap_Click()

Me.Tag = OldDate: Me.Hide

End Sub
Private Sub Cmd_NonDate_Click()

Me.Tag = "?": Me.Hide

End Sub
Private Sub Cmd_Suppr_Click()

Me.Tag = "": Me.Hide

End Sub
Private Sub UserForm_Initialize()

Dim i

CBox_Mois.AddItem "janvier"
CBox_Mois.AddItem "décembre"
CBox_Mois.AddItem "mars"
CBox_Mois.AddItem "avril"
CBox_Mois.AddItem "mai"
CBox_Mois.AddItem "juin"
CBox_Mois.AddItem "juillet"
CBox_Mois.AddItem "août"
CBox_Mois.AddItem "septembre"
CBox_Mois.AddItem "octobre"
CBox_Mois.AddItem "novembre"
CBox_Mois.AddItem "décembre"
For i = 1950 To 2050: CBox_An.AddItem i: Next

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

If CloseMode = vbFormControlMenu Then
    MsgBox "Vous ne pouvez pas utiliser ce bouton de fermeture." & Chr(13) & Chr(13) & "Veuillez cliquer sur la commande ou sur la touche Echap"
    Cancel = True
End If

End Sub
Private Sub CBox_An_Change()

If EvitSub Then Exit Sub

Décalage = CBox_An.ListIndex - OldAn
OldAn = CBox_An.ListIndex
ModifierDate Décalage * 12

End Sub
Private Sub CBox_Mois_Change()

If EvitSub Then Exit Sub

Décalage = CBox_Mois.ListIndex - OldMois
OldMois = CBox_Mois.ListIndex
ModifierDate Décalage

End Sub
Sub ModifierDate(i As Integer)

Dim j As Byte: Dim m As Byte: Dim Y As Integer

 j = Day(Me.Tag): m = Month(Me.Tag): Y = Year(Me.Tag)
If i > 11 Or i < -11 Then Y = Y + i / 12 Else m = m + i
If Charge Then Me.Tag = j & "/" & m & "/" & Y
Do Until IsDate(Me.Tag)
    j = j - 1
    If Charge Then Me.Tag = j & "/" & m & "/" & Y
Loop
MajControle

End Sub
Private Sub D1_Click()

If Charge Then Me.Tag = D1.Tag: Me.Hide

End Sub
Private Sub D2_Click()

If Charge Then Me.Tag = D2.Tag: Me.Hide

End Sub
Private Sub D3_Click()

If Charge Then Me.Tag = D3.Tag: Me.Hide

End Sub
Private Sub D4_Click()

If Charge Then Me.Tag = D4.Tag: Me.Hide

End Sub
Private Sub D5_Click()

If Charge Then Me.Tag = D5.Tag: Me.Hide

End Sub
Private Sub d6_Click()

If Charge Then Me.Tag = D6.Tag: Me.Hide

End Sub
Private Sub D7_Click()

If Charge Then Me.Tag = D7.Tag: Me.Hide

End Sub
Private Sub D8_Click()

If Charge Then Me.Tag = D8.Tag: Me.Hide

End Sub
Private Sub D9_Click()

If Charge Then Me.Tag = D9.Tag: Me.Hide

End Sub
Private Sub D10_Click()

If Charge Then Me.Tag = D10.Tag: Me.Hide

End Sub
Private Sub D11_Click()

If Charge Then Me.Tag = D11.Tag: Me.Hide

End Sub
Private Sub D12_Click()

If Charge Then Me.Tag = D12.Tag: Me.Hide

End Sub
Private Sub D13_Click()

If Charge Then Me.Tag = D13.Tag: Me.Hide

End Sub
Private Sub D14_Click()

If Charge Then Me.Tag = D14.Tag: Me.Hide

End Sub
Private Sub D15_Click()

If Charge Then Me.Tag = D15.Tag: Me.Hide

End Sub
Private Sub D16_Click()

If Charge Then Me.Tag = D16.Tag: Me.Hide

End Sub
Private Sub D17_Click()

If Charge Then Me.Tag = D17.Tag: Me.Hide

End Sub
Private Sub D18_Click()

If Charge Then Me.Tag = D18.Tag: Me.Hide

End Sub
Private Sub D19_Click()

If Charge Then Me.Tag = D19.Tag: Me.Hide

End Sub
Private Sub D20_Click()

If Charge Then Me.Tag = D20.Tag: Me.Hide

End Sub
Private Sub D21_Click()

If Charge Then Me.Tag = D21.Tag: Me.Hide

End Sub
Private Sub D22_Click()

If Charge Then Me.Tag = D22.Tag: Me.Hide

End Sub
Private Sub D23_Click()

If Charge Then Me.Tag = D23.Tag: Me.Hide

End Sub
Private Sub D24_Click()

If Charge Then Me.Tag = D24.Tag: Me.Hide

End Sub
Private Sub D25_Click()

If Charge Then Me.Tag = D25.Tag: Me.Hide

End Sub
Private Sub D26_Click()

If Charge Then Me.Tag = D26.Tag: Me.Hide

End Sub
Private Sub D27_Click()

If Charge Then Me.Tag = D27.Tag: Me.Hide

End Sub
Private Sub D28_Click()

If Charge Then Me.Tag = D28.Tag: Me.Hide

End Sub
Private Sub D29_Click()

If Charge Then Me.Tag = D29.Tag: Me.Hide

End Sub
Private Sub D30_Click()

If Charge Then Me.Tag = D30.Tag: Me.Hide

End Sub
Private Sub D31_Click()

If Charge Then Me.Tag = D31.Tag: Me.Hide

End Sub
Private Sub D32_Click()

If Charge Then Me.Tag = D32.Tag: Me.Hide

End Sub
Private Sub D33_Click()

If Charge Then Me.Tag = D33.Tag: Me.Hide

End Sub
Private Sub D34_Click()

If Charge Then Me.Tag = D34.Tag: Me.Hide

End Sub
Private Sub D35_Click()

If Charge Then Me.Tag = D35.Tag: Me.Hide

End Sub
Private Sub D36_Click()

If Charge Then Me.Tag = D36.Tag: Me.Hide

End Sub
Private Sub D37_Click()

If Charge Then Me.Tag = D37.Tag: Me.Hide

End Sub
Private Sub D38_Click()

If Charge Then Me.Tag = D38.Tag: Me.Hide

End Sub
Private Sub D39_Click()

If Charge Then Me.Tag = D39.Tag: Me.Hide

End Sub
Private Sub D40_Click()

If Charge Then Me.Tag = D40.Tag: Me.Hide

End Sub
Private Sub D41_Click()

If Charge Then Me.Tag = D41.Tag: Me.Hide

End Sub
Private Sub D42_Click()

If Charge Then Me.Tag = D42.Tag: Me.Hide

End Sub


VB: 
' gestion des erreurs
Private Sub TextBox1_AfterUpdate()
On Error GoTo messagerreur1
TextBox1 = Format(TextBox1, "Short Date")
Exit Sub
messagerreur1:
    MsgBox ("le format date n'est pas valide, il faut : Jour/Mois/année !")
    TextBox1 = Empty
   
End Sub

Private Sub TextBox1_Change()
On Error Resume Next
    TextBox1.Text = Lbl_Date.Caption  ' ajouter
End Sub

Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.TextBox1.Value = Format(Now, "dd/mm/yyyy")
Cancel = True
End Sub

Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' ajouter par double clic on vide
UserForm1.TextBox3.Text = Empty
End Sub

Private Sub TextBox3_Change()
On Error Resume Next
    UserForm1.TextBox3.Text = Lbl_DateFIN.Caption  ' ajouter
End Sub

' lorsque l'on click dans la zone de text
' le format date disparait
Private Sub TextBox1_Enter()
    If UserForm1.TextBox1 = "JJ/MM/AAAA" Then
    UserForm1.TextBox1 = ""
    End If
   
  On Error Resume Next
    UserForm1.TextBox1.Text = Lbl_Date.Caption  ' ajouter
End Sub

' lorsque l'on click dans la zone de text
' le format date réapparait
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If UserForm1.TextBox1 = "" Then
    UserForm1.TextBox1 = "JJ/MM/AAAA"
    End If
End Sub

Private Sub Textbox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' Permet de sélectionner les chiffres et la barre / , uniquement.
' 123456789/
' merci à X Cellus
If Not ((KeyAscii > 46 And KeyAscii < 58)) Or Len(TextBox1.Text) > 9 Then KeyAscii = 0
End Sub
 
Dernière édition:
Trier par date Trier par votes
V

VBgalère

XLDnaute Nouveau
Dranreb à dit:
Mais vous n'avez rien à me transmettre. Je parle de votre classeur de test mais avec l'UserForm complètement réécrit.
Ouais, avec votre problème de société ça sent le gaz pour ce qui est de la mise en place du complément xlam. Je vais installer les modules de service (un module standard et 12 modules de classe)
Cliquez pour agrandir...
Je veux bien avoir une version dans ce cas merci. Je verrais si le xlam est accepté mais il me semble que l’ancien en poste avait proposé quelque chose dans ce genre mais que ça avait été refusé. Merci
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Résolu(e)
XL 2019 Gestion "pseudo-évènements" sur un userform
2
Réponses
15
Affichages
460
ThierryP
T
N
  • Question
Microsoft 365 Recherche dans un tableau structuré à partir d'une TextBox
Réponses
11
Affichages
268
NONO14
N
D
  • Question
XL 2010 Recherche cellule vide sur une ligne
Réponses
9
Affichages
256
job75
job75
lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
487
AtTheOne
AtTheOne
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
329
Minus&Cortex
M
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
487
Claudinedu13
C
D
  • Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
758
AtTheOne
AtTheOne
N
  • Question
Microsoft 365 appel des sous-routine
Réponses
3
Affichages
177
Dranreb
Dranreb
ralph45
  • Question
Microsoft 365 [VBA] Listes déroulantes à choix multiples sur N colonnes discontinues
Réponses
4
Affichages
526
ralph45
ralph45
F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
410
Francky79
F

Membres actuellement en ligne

11 membres et 229 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 711
Messages
2 112 125
Membres
111 430
dernier inscrit
rebmania67