اذهب الي المحتوي
أوفيسنا

حساب الفرق بين الأوقات والتواريخ (سنة - شهر - اسبوع - ساعة - دقيقة - ثانية)


SEMO.Pa3x

الردود الموصى بها

السلام عليكم ورحمة الله وبركاته، كيف حالكم اخواني الأفاضل.

مبارك عليكم حلول شهر رمضان المبارك أعاده الله علينا وعليكم باليمن والخير والبركات.

اقدم لكم فنكشن لإحتساب المدة بين تاريخين

سنة - شهر - اسبوع - ساعة - دقيقة - ثانية

سؤال: ما الفائدة من هذا الفنكشن؟ بالدرجة الأولى سيُفيد أصحاب برامج الأقساط والتقسيط لإحتساب فترات التأخير والإستحقاق وغيرها.

وربما هنالك استخدامات أخرى له، حسب احتياج كل شخص

الفنكشن:

Public Function MainElapsedTime(d1, d2) As String
    d1 = CDate(d1)
    d2 = CDate(d2)
    vSecs = DateDiff("s", [d1], [d2])
    MainElapsedTime = ElapsedTimeAsTextRecur(vSecs)
End Function

Public Function ElapsedTimeAsTextRecur(ByVal pvSecs, Optional ByVal pvSecBlock)
    'recursive time lapse given seconds
    Dim vTxt
    Dim iNum As Long
    Const kDAY = 86400
    Const kSECpYR = 31536000
    
    '60  sec    = 1 min   =  60         sec
    '60  min    = 1 hour  =  3,600      sec
    '24  hour   = 1 day   =  86,400     sec
    '07  days   = 1 week  =  604,800    sec
    '30  days   = 1 month =  25,92,000  sec
    '12  months = 1 year  =  31,536,000 sec
    
    'YEARS
    If IsMissing(pvSecBlock) Then pvSecBlock = kSECpYR
    iNum = pvSecs \ pvSecBlock
    
    Select Case pvSecBlock
        Case kSECpYR 'yr
            sUnit = "years"
            If iNum > 0 Then
                vTxt = iNum & " Years "
                pvSecs = pvSecs - (iNum * pvSecBlock)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 2592000)
            
        Case 2592000 'MO
            sUnit = "months"
            If iNum > 0 Then
                If iNum > 11 Then iNum = 11
                vTxt = vTxt & iNum & " Months "
                pvSecs = pvSecs - (iNum * pvSecBlock)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 604800)
            
        Case 604800 'WEEK
            sUnit = "weeks"
            If iNum > 0 Then
                If iNum > 3 Then iNum = 3
                vTxt = vTxt & iNum & " Weeks "
                pvSecs = pvSecs - (iNum * kDAY * 7)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 86400)
            
        Case kDAY 'day
            sUnit = "days"
            If iNum > 0 Then
                vTxt = vTxt & iNum & " Days "
                pvSecs = pvSecs - (iNum * kDAY)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 3600)
            
        Case 3600 'hrs
            sUnit = "hrs"
            If iNum > 23 Then iNum = 23
            If iNum > 0 Then
                vTxt = vTxt & iNum & " Hours "
                pvSecs = pvSecs - (iNum * pvSecBlock)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 60)
            
        Case 60 'min
            sUnit = "mins"
            If iNum > 0 Then
                vTxt = vTxt & iNum & " Minutes "
                pvSecs = pvSecs - (iNum * pvSecBlock)
            End If
            vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 1)
            
        Case Else
            
            sUnit = "secs"
            If pvSecs > 0 Then vTxt = vTxt & pvSecs & " Seconds"
    End Select
    
    ElapsedTimeAsTextRecur = vTxt
End Function

 

الإستخدام بسيط جدا في الإستعلامات او في النماذج او التقارير كالآتي:

MainElapsedTime("Here your date", Date())

---------------------------------------------------
Example: MsgBox MainElapsedTime("6/3/2020", "14/4/2021")

النتيجة:

image.png.da3cbf91cd2f5a63cd3fb859713ff33a.png 

 

هنا انا قمت بمقارنة تاريخين فقط بدون أوقات، سأقوم الآن بمقارنة تاريخ مع وقت

MsgBox MainElapsedTime("2/02/2019 12:07:16 pm", "13/04/2021 1:08:6 am")

 

النتيجة:

image.png.7dae8620ea4efe4e12fb3ce607cd58a0.png

 

للأمانة الكود ليس من كتابتي 100%، فقط انا قمت بالتعديل عليه ليصبح بشكل افضل..

تحياتي وانتضرو مفاجئتي في الموضوع القادم  :29::29::29:

  • Like 4
  • Thanks 4
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information