I facilitate below code based on XMLHTTP 6. & api. in order to check whether internet is connected. IF internet is connected excel sheet will be loaded otherwise workbook will be closed (If there is else other opened workbooks) or application quit (It this workbook is the only one)
The code works fine If I disconnect ethernet connection or wifi connection. However If I switch off modem/router or disconnect Wan cable of modem / router randomly I receive false positives. Where do I go wrong?
Thanks
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: Home - My Engineering World
'-------------------------------------------------------------------------------
'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 = "Abu Dhabi, United Arab Emirates - current and accurate time"
'Build the XMLHTTP object and check if was created successfully.
On Error GoTo errorHandler
Set request = CreateObject("MSXML2.ServerXMLHTTP.6.0")
If Err.Number <> 0 Then
Exit Function
End If
On Error GoTo errorHandler
'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
Exit Function
errorHandler:
MsgBox "Error" & Str(Err.Number) & Chr(13) & _
"Validation failed!" & Chr(13) & _
"Please make sure you have a valid internet connection.", vbCritical, "Acolator Units"
If Workbooks.count = 1 Then
Application.DisplayAlerts = False
Application.Quit
ThisWorkbook.Save
Else
ThisWorkbook.Close 'SaveChanges:=True
End If
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: Home - My Engineering World
'-------------------------------------------------------------------------
'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
The code works fine If I disconnect ethernet connection or wifi connection. However If I switch off modem/router or disconnect Wan cable of modem / router randomly I receive false positives. Where do I go wrong?
Thanks
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: Home - My Engineering World
'-------------------------------------------------------------------------------
'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 = "Abu Dhabi, United Arab Emirates - current and accurate time"
'Build the XMLHTTP object and check if was created successfully.
On Error GoTo errorHandler
Set request = CreateObject("MSXML2.ServerXMLHTTP.6.0")
If Err.Number <> 0 Then
Exit Function
End If
On Error GoTo errorHandler
'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
Exit Function
errorHandler:
MsgBox "Error" & Str(Err.Number) & Chr(13) & _
"Validation failed!" & Chr(13) & _
"Please make sure you have a valid internet connection.", vbCritical, "Acolator Units"
If Workbooks.count = 1 Then
Application.DisplayAlerts = False
Application.Quit
ThisWorkbook.Save
Else
ThisWorkbook.Close 'SaveChanges:=True
End If
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: Home - My Engineering World
'-------------------------------------------------------------------------
'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
