DominoArea.org [Archive]

Cette fonction permet de récupérer la date correspondant par exemple au premier lundi du mois

Code : Tout sélectionner

Public Function DateMonthSelect(wnbMonth As Integer,wnbYear As Integer,wnbWeekDay As Integer, wnbPosition As Integer)As String
   
   'wnbMonth : mois a traité
   'wnbYear : année a traité
   'wnbWeekDay : numéro du jours a rechercher ( 1 = dimanche)
   'wnbPosition : position recherche du jours dans le mois (le premier le deuxieme ...)
   'si wnbPosition est passé en négatif la recherche ce fait a l'envers le derniere lundi ou l'avant derniere lundi...
   
   'Declaration Variable
    'Declaration Variable
   Dim nbYear As Integer
   Dim nbDay As Integer
   Dim nbDay2 As Integer
   Dim i As Integer
   Dim J As Integer
   
   On Error Goto ErreurHandle
   
   DateMonthSelect = ""
   
   If wnbMonth = 0 Then
      Error 9999, "wnbMonth = 0"
      Exit Function
   Elseif Abs(wnbMonth) > 12 Then
      Error 9999,"wnbMonth > 12"
      Exit Function
   End If
   
   Select Case Abs(wnbYear)
   Case 0
      Error 9999, "wnbYear = 0"
      Exit Function
   Case Is < 101
        'si inférieur à 100 on considère que la date est sur 2 chiffres
      nbYear = 2000+Abs(wnbYear)
   Case 101 To 1500
      Error 9999, "wnbYear <1500 & > 100"
      Exit Function
   Case Is > 3000
      Error 9999, "wnbYear > 3000"
      Exit Function
   Case Else
      nbYear = Abs(wnbYear)
   End Select
   
   If wnbPosition = 0 Then
      Error 9999, "wnbPosition = 0"
      Exit Function
   Elseif Abs(wnbPosition) > 5 Then
      Error 9999, "wnbPosition > 5 (5 weeks max by month)"
      Exit Function
   End If
   
   If Abs(wnbWeekDay) = 0 Then
      Error 9999, "wnbWeekDay = 0"
      Exit Function
   Elseif Abs(wnbWeekDay) > 7 Then
      Error 9999, "wnbWeekDay > 7 (7 days by weeks)"
      Exit Function
   End If
   
   Select Case Abs(wnbMonth)
   Case 1,3,5,7,8,10,12
      'mois de 31 jours
      nbDay = 31
   Case 4,6,9,11
      'mois de 30 jour
      nbDay = 30
   Case 2
      ' le nombre de jour du mois de février varie si l'année est bissextile.
      If isBissextile(nbYear) = True Then
         nbDay = 29
      Else
         nbDay = 28
      End If
   End Select
   
   J=0
   nbDay2 = 0
   
   If wnbPosition > 0 Then
        'recherche croissante
      For i = 1 To nbDay
         If Weekday(Datenumber(nbYear,Abs(wnbMonth),i)) = Abs(wnbWeekDay) Then
            J=J+1
            nbDay2 = i
            If J = Abs(wnbPosition) Then
               DateMonthSelect = Format(Datenumber(nbYear,Abs(wnbMonth),i),"DD/MM/YYYY")
               Exit Function
            End If
         End If
      Next
   Else
        'recherche décroissante
      For i = nbDay To 1 Step -1
         If Weekday(Datenumber(nbYear,Abs(wnbMonth),i)) = Abs(wnbWeekDay) Then
            J=J+1
            nbDay2 = i
            If J = Abs(wnbPosition) Then
               DateMonthSelect = Format(Datenumber(nbYear,Abs(wnbMonth),i),"DD/MM/YYYY")
               Exit Function
            End If
         End If
      Next
   End If
   
   If nbDay2 <> 0 Then
         'sinon récupere la derniere date valide
      DateMonthSelect = Format(Datenumber(nbYear,Abs(wnbMonth),nbDay2),"DD/MM/YYYY")
   End If
   
   nbYear = 0
   nbDay = 0
   nbDay2 = 0
   i = 0
   J = 0
   
   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   DateMonthSelect= ""
   Exit Function
End Function

Code : Tout sélectionner

Public Function isBissextile(Byval wnbYear) As Integer
   
      'L'année est bissextile si elle est divisible par quatre.
      'Toutefois, les années divisibles par 100 ne sont pas bissextiles,
      'mais les années divisibles par 400 le sont.
   
      'L'année est bissextile si elle est divisible par quatre.
      'Toutefois, les années divisibles par 100 ne sont pas bissextiles,
      'mais les années divisibles par 400 le sont.
   
      'Déclaration Variable
   Dim nbYear As Integer
   
   On Error Goto ErreurHandle
   
   Select Case Abs(wnbYear)
   Case 0
      Error 9999, "wnbYear = 0"
      Exit Function
   Case Is < 101
        'si inférieur à 100 on considère que la date est sur 2 chiffres
      nbYear = 2000+ Abs(wnbYear)
   Case 101 To 1500
      Error 9999, "wnbYear <1500 & > 100"
      Exit Function
   Case Is > 3000
      Error 9999, "wnbYear > 3000"
      Exit Function
   Case Else
      nbYear = Abs(wnbYear)
   End Select
   
   If nbYear Mod 4 = 0 Then
      If nbYear Mod 100 = 0 Then
         If nbYear Mod 400 = 0 Then
            isBissextile = True
         Else
            isBissextile = False
         End If
      Else
         isBissextile = True
      End If
   Else
      isBissextile = False
   End If
   
   nbYear = 0
   
   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : IsBissextile)"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) +Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   isBissextile = False
   Exit Function
End Function