.jpg "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: [email protected]
'site: https://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: [email protected]
'site: https://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: [email protected]
'site: https://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
The file can be opened with Excel 2007 or newer. Please enable macros before using it.
