Calcul de Durée entre deux Dates

Signaler
Messages postés
99
Date d'inscription
jeudi 17 janvier 2008
Statut
Membre
Dernière intervention
25 juillet 2013
-
Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
-
Bonjour à tous, je sollicite votre aide pour m'aider à resoudre mon problèment en matière de calcul de durée entre deux dates sous vb6. Merci d'avance.
Voici donc mon Problème.
Function CalculDuree(DateN As String, DateCS As String) As String

If IsDate(DateN) = False Then Exit Function
If IsDate(DateCS) = False Then Exit Function

Dim jN1, jC1, mN1, mC1, aN1, aC1 As Integer
Dim Jage, Mage, Aage As Integer
Dim Jdif As Integer

jN1 = Day(DateN)
jC1 = Day(DateCS)
mN1 = Month(DateN)
mC1 = Month(DateCS)
aN1 = Year(DateN)
aC1 = Year(DateCS)

If aC1 < aN1 Then Exit Function
If aC1 = aN1 And mC1 < mN1 Then Exit Function
If aC1 aN1 And mC1 mN1 And jC1 < jN1 Then Exit Function
If aC1 aN1 And mC1 mN1 And jC1 = jN1 Then

Mage = 0
Jage = 0
Aage = 0

GoTo caline1
End If

' Permet de savoir le nombre de jours du mois (fevrier inclus)
Dim sdt1 As Date
Dim sdt2 As Date

sdt1 = DateValue("1" & "/" & mN1 & "/" & aN1)
sdt2 = DateValue("1" & "/" & mN1 + 1 & "/" & aN1)
Jdif = DateDiff("d", sdt1, sdt2)

If jC1 < jN1 Then
If mC1 > mN1 Then
Mage = (mC1 - 1) - mN1
Jage = (jC1 + Jdif) - jN1
Aage = aC1 - aN1
GoTo caline1
End If

If mC1 = mN1 Then
Aage = aC1 - 1 - aN1
Mage = (mC1 + 11) - mN1
Jage = (jC1 + Jdif) - jN1
GoTo caline1
End If

If mC1 < mN1 Then
Mage = (mC1 + 11) - mN1
Jage = (jC1 + Jdif) - jN1
Aage = aC1 - 1 - aN1
GoTo caline1
End If
End If

If jC1 >= jN1 Then
If mC1 > mN1 Then
Jage = jC1 - jN1
Mage = mC1 - mN1
Aage = aC1 - aN1
GoTo caline1
End If

If mC1 = mN1 Then
Jage = jC1 - jN1
Mage = mC1 - mN1
Aage = aC1 - aN1
GoTo caline1
End If

If mC1 < mN1 Then
Jage = jC1 - jN1
Mage = (mC1 + 12) - mN1
Aage = aC1 - 1 - aN1
GoTo caline1
End If

End If

caline1:
CalculDuree = Aage & "A " & Mage & "M " & Jage & "J"

End Function

UTILISATION:

Private Sub DateCible_Change()

On Error Resume Next
TxtStat(5).Text = DateCible.Text

Dim mDateSce As String
Dim mDatePro As String
Dim mDateCbl As String

mDateSce = TxtStat(6).Text
mDatePro = TxtStat(7).Text
mDateCbl = TxtStat(5).Text

TxtStat(8).Text = CalculDuree(mDateSce, mDateCbl)
TxtStat(9).Text = CalculDuree(mDatePro, mDateCbl)

End Sub

Si je prends
DateCible = 31/12/2010
mDateSce = 01/06/1986
mDatePro = 01/10/2009

Résultat:

TxtStat(8).Text = 23A 6M 30J

TxtStat(9).Text = 1A 2M 30J

Alors que logiquement j'aurais du avoir :

TxtStat(8).Text = 23A 7M 0J
TxtStat(9).Text = 1A 3M 0J

Aidez s'il vous plait. Merci à tous

6 réponses

Messages postés
14008
Date d'inscription
samedi 29 décembre 2001
Statut
Modérateur
Dernière intervention
28 août 2015
74
Salut
Pas eu le courage de détailler ton code.
Juste un conseil : Intéresse-toi aux fonctions DateDiff et DateAdd
Tu verras que ce sera beaucoup plus sûr et plus simple.

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)
Messages postés
14008
Date d'inscription
samedi 29 décembre 2001
Statut
Modérateur
Dernière intervention
28 août 2015
74
PS : Tape aussi "calculer age" dans la recherche parmi les codes en excluant .Net : tu trouveras des exemples
Messages postés
14008
Date d'inscription
samedi 29 décembre 2001
Statut
Modérateur
Dernière intervention
28 août 2015
74
Pour le principe :
- tu calcules le nombre d'années entières entre tes deux dates --> mémoire Années
- tu ajoutes ces années entières à la vieille date
- tu calcules le nombre de mois entiers entre tes deux dates --> mémoire Mois
- tu ajoutes ces mois entiers à la vieille date
- tu calcules le nombre de jour entiers entre tes deux dates --> mémoire Jours
Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
67
algo de base...

Dim nbJours As Long
Dim nbMois As Long
Dim nbAnnees As Long
    nbJours = (#3/13/2010# - #12/31/1983#)
    nbAnnees = nbJours / 365.25
    nbJours = nbJours - nbAnnees * 365.25
    nbMois = nbJours / 30
    nbJours = nbJours - nbMois * 30
    MsgBox nbAnnees & " A - " & nbMois & " M - " & nbJours & " J"



Renfield - Admin CodeS-SourceS - MVP Visual Basic
Messages postés
99
Date d'inscription
jeudi 17 janvier 2008
Statut
Membre
Dernière intervention
25 juillet 2013
1
Je voudrais vous remercier tous pour l'aide que vous avez bien voulu m'apporter. J'y suis arrivé et je publie ici le résultat qui pourrait aider d'autres personnes qui se retrouveraient dans la même situation que moi.
La fonction devient donc:

Public Function AgeDuree(D1 As Date, D2 As Date) As String

Dim Annees As Long, Mois As Long, Jours As Long, DecalMois As Long

On Error GoTo Erreur:
If D1 > D2 Then
AgeDuree = "Dates invalides"
Exit Function
End If

DecalMois = IIf(Day(D2) < Day(D1), 1, 0)

Annees = Year(D2) - Year(D1) - Switch(Month(D2) < Month(D1), 1, _
Month(D2) = Month(D1), DecalMois, True, 0)

Mois = (Month(D2) - Month(D1) - DecalMois + 12) Mod 12

Jours = Day(D2) - Day(D1) + DecalMois * Day(DateSerial(Year(D2), Month(D2), 1) - 1)

If Jours = 30 Then
Jours = Jours - 30
Mois = Mois + 1
End If

If Jours 30 And Mois 11 Then
Jours = Jours - 30
Mois = Mois + 1
If Mois + 1 = 12 Then
Mois = Mois - 12
Annees = Annees + 1
End If
End If

If Mois = 12 Then
Mois = Mois - 12
Annees = Annees + 1
End If

AgeDuree = Trim(Annees & "A " & Mois & "M " & Jours & "J")
Exit Function

Erreur:

AgeDuree = "Calcul Impossible"

End Function

Merci encore à tous et particulièrement à Renfield et à Jack. Bonne journée à vous.
Messages postés
17286
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
23 décembre 2019
67
plutot complexe...

If Jours 30 And Mois 11 Then
Jours = Jours - 30
Mois = Mois + 1
If Mois + 1 = 12 Then
Mois = Mois - 12
Annees = Annees + 1
End If
End If

étrange, non ?

pour entrer dans le corps principal, il faut Mois = 11
tu y fait Mois = Mois +1
donc Mois = 12
du coup, le test If Mois + 1 = 12
ne sera jamais utilisé ....

Renfield - Admin CodeS-SourceS - MVP Visual Basic & Spécialiste des RegExp