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

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:

Dranreb

XLDnaute Barbatruc
Il ne s'agit pas d'ajouter le code. Il s'agit de glisser/déplacer l'élément UFmCalend ou UFmCalenS du projet VBA du MonCalendrier.xlsm vers celui de votre classeur, c'est à dire l'y trainer dans l'explorateur de projet avec le curseur gauche de la souris maintenu enfoncé, puis d'invoquer ses méthodes si faciles à utiliser.
 

patricktoulon

XLDnaute Barbatruc
Bonjour
ou le mien
et pareil glisser le userform calendar dans son projet
tout les modes d'appel sont expliqués et des exemples de codes sont en tète de module
 

Dranreb

XLDnaute Barbatruc
Dans votre UserForm il ne vous faut rien d'autre que ces deux procédures :
VB:
Private Sub TextBox1_Enter()
   UFmCalend.Coupler "Début :", TextBox1
   End Sub
Private Sub TextBox3_Enter()
   UFmCalend.Coupler "Fin :", TextBox3
   End Sub
Mais j'ai aussi l'impression que tout serait à revoir plus simplement avec ça :
C'est un précurseur xlsm qui demande à son ouverture la permission de s'installer en xlam dans votre dossier de compléments. Son projet VBA CLsCAs est à cocher dans les références de celui du classeur utilisateur.
 
Dernière édition:

VBgalère

XLDnaute Nouveau
Dans votre UserForm il ne vous faut rien d'autre que ces deux procédures :
VB:
Private Sub TextBox1_Enter()
   UFmCalend.Coupler "Début :", TextBox1
   End Sub
Private Sub TextBox3_Enter()
   UFmCalend.Coupler "Fin :", TextBox3
   End Sub
Mais j'ai aussi l'impression que tout serait à revoir plus simplement avec ça :
C'est un précurseur xlsm qui demande à son ouverture la permission de s'installer en xlam dans votre dossier de compléments. Son projet VBA CLsCAs est à cocher dans les références de celui du classeur utilisateur.
Merci beaucoup!
 

Dranreb

XLDnaute Barbatruc
Si vous êtes intéressé, je joindrais une refonte totale de votre classeur utilisant le CBxLCtlA.xlam.
L'avez vous installé ? Si vous ne souhaitez pas l'installer je peut équiper votre projet des modules de service nécessaires, il suffit de me le dire. En tout cas toute la programmation de ce nouvelu UFmIntvArceau est déjà écrite !
 

VBgalère

XLDnaute Nouveau
Si vous êtes intéressé, je joindrais une refonte totale de votre classeur utilisant le CBxLCtlA.xlam.
L'avez vous installé ? Si vous ne souhaitez pas l'installer je peut équiper votre projet des modules de service nécessaires, il suffit de me le dire. En tout cas toute la programmation de ce nouvelu UFmIntvArceau est déjà écrite !
Merci beaucoup pour la proposition. Le programme que je vous ai partagé est celui que j’ai récupéré. Le mien étant un projet professionnel ma société ne m’autorise pas à le publier sur internet. C’est un projet comportant énormément de code donc vous faire une copie clean sans information pro etc.. prendrais trop de temps. Au vu de la facilité d’ajout de votre module, je vais utiliser ce que vous m’avez envoyé pour faire un test car celui que j’ai aujourd’hui (issue du classeur partagé précédemment) fonctionne très bien vu que j’ai réussi à l’ajouter à tout mes userforms nécessitants des dates (10 userform avec entre 4 et 8 zones de dates). Je voulais simplement avoir une traduction du code afin de comprendre ce qui m’échappe. Je vais tester comme dit précédemment votre code car il dispose d’explications.
Merci encore.
 

VBgalère

XLDnaute Nouveau
Bonjour
ou le mien
et pareil glisser le userform calendar dans son projet
tout les modes d'appel sont expliqués et des exemples de codes sont en tète de module
Merci beaucoup
 

Dranreb

XLDnaute Barbatruc
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)
 

Discussions similaires

Réponses
5
Affichages
124