copy

Monday, 30 September 2013



Retrieve Time From An Internet Server (VBA Function)


Introduction



The motive behind the current post came from an e-mail request. A blog reader (Vikram) wanted to create a log file for one of his workbooks. He had already created one, but the problem was it worked with the local date and time. In other words, the log file retrieved the date and time that the user opened the workbook based on the computer date/time, so it was quite vulnerable. The user could just set his/her computer time one hour earlier for example and then open the workbook. In this way, he/she could “fool” the log file very easily.

In order to avoid the “cheating”, I develop a custom VBA function that works with internet time. The function (InternetTime) sends a request to an internet server and then uses the server response in order to retrieve the Greenwich mean date and time. In the function, the user can add (or subtract) an hour difference, so as to get the local date and time (for example Athens hour is GMT + 2). Note, however, that the function doesn’t take into account the Daylight Saving Time (or summer time), since this setting changes from location to location and for every year.

Apart from the VBA function, in the next section, you will find a Workbook Open event that demonstrates a way that the function can be used in order to create a log file.



VBA code



In the next lines except for the InternetTime function, you will find the ConvertDate function, which was developed for converting the date format retrieved from the specific server to a valid Excel date format.

Option Explicit

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:  10/01/2017
    '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("MSXML2.ServerXMLHTTP.6.0")
    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

Sub UpdateAll()

    'Recalculate all the workbook in order to update the InternetTIme function results.
    Application.CalculateFull
   
End Sub

Here is the Workbook Open event.

Option Explicit

Private Sub Workbook_Open()
    
    '------------------------------------------------------------------------------
    'This event shows how you can use the custom InternetTime function in order
    'to create a log file at this workbook. Everytime someone opens this
    'workbook the GMT date and time is written in the sheet named "Log".
    
    '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 LastRow     As Long
    Dim RightNow    As Date
    
    'Disable screen flickering.
    Application.ScreenUpdating = False
    
    'Find the last row.
    With shLog
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    'Regrieve the date/time from the server. You can add an hour difference to the
    'InternetTime function in order to get the log details at your local time.
    RightNow = InternetTime()
    
    'Write the date and time to the Log sheet.
    With shLog
        .Cells(LastRow + 1, 1) = DateSerial(Year(RightNow), Month(RightNow), Day(RightNow))
        .Cells(LastRow + 1, 2) = TimeSerial(Hour(RightNow), Minute(RightNow), Second(RightNow))
    End With
    
    'Autofit the columns.
    shLog.Columns("A:B").EntireColumn.AutoFit
    
    'Activate the Function sheet.
    shGMT.Activate
        
    'Save the new values.
    ThisWorkbook.Save
    
    'Enable the screen.
    Application.ScreenUpdating = True
    
End Sub

In the sample Excel file, I have used this technique in order to add the description to the above function.

Update 20/11/2013: Thanks to Steve Lewis' suggestions the function was simplified and updated. Thank you, Steve!



Downloads



Download

The file can be opened with Excel 2007 or newer. Please enable macros before using it.

Did you like this post? If yes, then share it with your friends. Thank you!


Categories:


Mechanical Engineer (Ph.D. cand.), M.Sc. Cranfield University, Dipl.-Ing. Aristotle University, Thessaloniki - Greece.
Communication: e-mail, Facebook, Twitter, Google+ and Linkedin. More info