اعتماد وقت وتاريخ الانترنت في الحضور وغيره

[ابوخليل]

بسم الله الرحمن الرحيم

احبتي الكرام

السلام عليكم ورحمة الله وبركاته    وبعد :

وجدت لكم دالة  تأخذ التاريخ والوقت الدولي من الانترنت ، مع شروحات للاكواد وافية

       كثير من الاخوة يحتاجون هذه الدالة خاصة الذين يعتمدون على جهاز واحد ، وذلك من اجل سد ثغرات احتمال التلاعب بوقت وتاريخ الجهاز
من الشروط وجود خدمة الانترنت ، 
واعتقد في اليوم الحاضر اصبح من الضروريات التي لا يتصور الاستغناء عنها

هذه الدالة جميلة جدا  تجلب التاريخ  والوقت الدولي مع امكانية  مراعاة فارق التوقيت حول العالم

الدالة : 

 

InternetTime()' التاريخ والوقت في جرينتش
InternetTime(3)'  في مكة المكرمة 
InternetTime(2)'  في مصر 

امكانية عمل التنسيقات عليه بالضبط تماما كما نتعامل مع الدالة()Date أو ()NOW
فهذا التنسيق يعطينا الوقت في مكة

Format(InternetTime(3);"hh:mm:ss AM/PM")

وكما تلاحظون  ان الارقام التي بين الاقواس تعني فارق الزمن 

وهذه هي الوحدات النمطية :

Function InternetTime(Optional GMTDifference As Integer) As Date
    '-----------------------------------------------------------------------------------
    'This function returns the Greenwich Mean Time retrieved from an internet server.
    'You can use the optional argument GMTDifference in order to add (or subtract)
    'an hour from the GMT time. For Example if you call the function as:
    '=InternetTIme(2) it will return the (local) hour GMT + 2. Note that the
    'GMTDifference variable is an integer number.
   
    'Written by:    Christos Samaras
    'Date:          25/09/2013
    'Last Updated:  20/11/2013
    'e-mail:        xristos.samaras@gmail.com
    'site:          http://www.myengineeringworld.net

    'Declaring the necessary variables.
    Dim Request     As Object
    Dim ServerURL   As String
    Dim Results     As String
    Dim NetDate     As String
    Dim NetTime     As Date
    Dim LocalDate   As Date
    Dim LocalTime   As Date
   
    'Check if the time difference is within the accepted range.
    If GMTDifference < -12 Or GMTDifference > 14 Then
        Exit Function
    End If

    'The server address.
    ServerURL = "http://www.timeanddate.com/worldclock/fullscreen.html?n=2"
   
    'Build the XMLHTTP object and check if was created successfully.
    On Error Resume Next
    Set Request = CreateObject("Microsoft.XMLHTTP")
    If Err.Number <> 0 Then
        Exit Function
    End If
    On Error GoTo 0
   
    'Create the request.
    Request.Open "GET", ServerURL, False, "", ""
   
    'Send the request to the internet server.
    Request.Send
   
    'Based on the status node result, proceed accordingly.
    If Request.readyState = 4 Then
       
        'If the request succeed, the following line will return
        'something like this: Mon, 30 Sep 2013 18:33:23 GMT.
        Results = Request.getResponseHeader("date")
       
        'Use the Mid function to get something like: 30 Sep 2013 18:33:23.
        Results = Mid(Results, 6, Len(Results) - 9)
       
        'Use the Left and Right function to distinguish the date and time.
        NetDate = Left(Results, Len(Results) - 9) '30 Sep 2013
        NetTime = Right(Results, 8) '18:33:23
       
        'Convert the date into a valid Excel date 30 Sep 2013 -> 30/9/2013.
        'Required for countries that have some non-Latin characters at their alphabet (Greece, Russia, Serbia etc.).
        LocalDate = ConvertDate(NetDate)

        'Add the hour difference to the retrieved GMT time.
        LocalTime = NetTime + GMTDifference / 24

        'Return the local date and time.
        InternetTime = LocalDate + LocalTime
   
    End If
   
    'Release the XMLHTTP object.
    Set Request = Nothing

End Function

Function ConvertDate(strDate As String) As Date
   
    '-------------------------------------------------------------------------
    'This function converts the input date into a valid Excel date.
    'For example the 30 Sep 2013 becomes 30/9/2013.
    'Required for countries that have non-Latin characters at their alphabet.
   
    'Written by:    Christos Samaras
    'Date:          25/09/2013
    'e-mail:        xristos.samaras@gmail.com
    'site:          http://www.myengineeringworld.net
    '-------------------------------------------------------------------------
   
    'Declaring the necessary variables.
    Dim MyMonth As Integer
   
    'Check the month and convert it to number.
    Select Case UCase(Mid(strDate, 4, 3))
        Case "JAN": MyMonth = 1
        Case "FEB": MyMonth = 2
        Case "MAR": MyMonth = 3
        Case "APR": MyMonth = 4
        Case "MAY": MyMonth = 5
        Case "JUN": MyMonth = 6
        Case "JUL": MyMonth = 7
        Case "AUG": MyMonth = 8
        Case "SEP": MyMonth = 9
        Case "OCT": MyMonth = 10
        Case "NOV": MyMonth = 11
        Case "DEC": MyMonth = 12
    End Select
   
    'Rebuild the date.
    ConvertDate = DateValue(Right(strDate, 4) & "/" & MyMonth & "/" & Left(strDate, 2))

End Function

وتطبيق المقال بهذا المثال :

db2.rar

[محمد ايمن]

جزاك الله كل خير

[محمد سلامة]

شكرا استاذنا ابوخليل 

[ابوخليل]

استدراك وتنويه :

     هنا موضوع يتحدث عن الفكرة  سبقنا الاستاذ محمد عصام  مشكورا  وارفق فيه مثالا جيدا 

[الحلبي]

استادنا / ابو خليل  حياك الله 

ياسلام عليك ما هدا الجمال 

ساقوم بالتطبيق ونعرض علي حضرتك النتيجة ان شاء الله

ولا انسي مجهود الاستاد/  ابا جودي هنا في تقديمه للمثال الاول

انت مبدع استاد / ابو خليل وربنا يبارك فيك

كل تقدير واحترام لك

[ابو جودي]

في 11/9/2016 at 15:05, ابوخليل said:

استدراك وتنويه :

     هنا موضوع يتحدث عن الفكرة  سبقنا الاستاذ محمد عصام  مشكورا  وارفق فيه مثالا جيدا 

العفو منك استاذى الحبيب ووالدى الكريم ما انا الا طالب علم  رفع الله قدركم ودرجاتكم فى الدنيا وفى  الجنان ان شاء الله
جزاكم الله خيرا 

[ابو جودي]

في 11/9/2016 at 16:00, حلبي said:

استادنا / ابو خليل  حياك الله 

ياسلام عليك ما هدا الجمال 

ساقوم بالتطبيق ونعرض علي حضرتك النتيجة ان شاء الله

ولا انسي مجهود الاستاد/  ابا جودي هنا في تقديمه للمثال الاول

انت مبدع استاد / ابو خليل وربنا يبارك فيك

كل تقدير واحترام لك

جزاكم الله خيرا اخى الحبيب على ذكركم واطرائكم بالرغم من المبالغة من قبلكم لجود اخلاقكم فلم اقم باى مجهود يذكر 

[الحلبي]

الاستاد / ابو خليل 

قمت بتطبيق المثال عندي والحمد الله كل شئ ضبط معي

ولكن سؤالي : ما سبب ثقل فتح النمودج اجد انه يأخد بعض الوقت اثناء الفتح هل بسبب انه يأخد الوقت من النت؟

وعلي اي حال فهو قام بحل مشكلة كبيرة لدي والفضل لله ثم لكم

دائما استادي/ ابو خليل  تحل مشاكلي وتكون خير عونا لي

استاد / ابا جودي هدا ليس باطراء ولكن هدا حقك عليَ انت حد محترم جدا

كل احترام وتقدير لكما 

[ابو جودي]

9 ساعات مضت, حلبي said:

الاستاد / ابو خليل 

قمت بتطبيق المثال عندي والحمد الله كل شئ ضبط معي

ولكن سؤالي : ما سبب ثقل فتح النمودج اجد انه يأخد بعض الوقت اثناء الفتح هل بسبب انه يأخد الوقت من النت؟

وعلي اي حال فهو قام بحل مشكلة كبيرة لدي والفضل لله ثم لكم

دائما استادي/ ابو خليل  تحل مشاكلي وتكون خير عونا لي

استاد / ابا جودي هدا ليس باطراء ولكن هدا حقك عليَ انت حد محترم جدا

كل احترام وتقدير لكما 

 دزاكم الله خيرا
اخى الحبيب تحية عطرة طيبة مباركة 
الملف عندى يفتح ولا يتعدى ةقت فتحه وتحميله للوقت اكثر من ثلاث ثوانى باقصى تقدير قد تكون سرعة الانترنت لها تأثير

[عاشق الرقي]

تسلم ايدك يا أستاذ أبو خليل

ولا يهون الجميع في هذا الصرح

بوركتم جميعا

[m.jafer]

الفكرة غير عملية فقد يفصل المستخدم الانترنت 

ماهو حل هذه المشكلة

الانترنت عندنا لا يسمح الا بالايميل اوتلوك فقط