TimeStamp

[Chris]

I currently have a spreadsheet set up that employees use to timestamp their
login, logout, lunch, etc. I have a button on the spreadsheet and a user
chooses a cell and clicks the button for a timestamp.

There is one problem I'm running into. A clever person could change their
system time before they click the button to alter their times since my macro
is using the Now() function.

Can someone please provide me with code to timestamp from an internet
database time or something? Or if you have other suggestions to get around
this, anything woud be helpful.

Thank you.

 

[Gary Brown]

I got this off Dick Kusleika's Daily Dose of Excel site quite some time ago
but never tried it.
I'm behind a firewall at work and can't try this right now.
Change the CONSTANT sURL to your time zone.
Hope it works.
Good Luck,

'/==============================/
Function GetRealTime() As Date
'get real date and time from the web
'Avoiding the System Clock by Dick Kusleika
' http://www.dicks-blog.com/ - 2005-01-31
'
' http://www.time.gov/images/worldzones.gif for ALL ZONES

'
Dim i As Integer, iCount As Integer
Dim ieApp As Object
Dim sDate As String
Dim lFirstCrLf As Long

On Error Resume Next

iCount = 50

Const lElement As Long = 36
Const ieREADYSTATE_COMPLETE As Long = 4

Const sURL = _
"http://www.time.gov/timezone.cgi?UTC-5"
' Const sURL = _
"http://www.time.gov/timezone.cgi?Eastern/d/-5"
' Const sURL = _
"http://www.time.gov/timezone.cgi?Central/d/-6"
' Const sURL = _
"http://www.time.gov/timezone.cgi?Mountain/d/-7"
' Const sURL = _
"http://www.time.gov/timezone.cgi?Pacific/d/-6"

Set ieApp = CreateObject("InternetExplorer.Application")

ieApp.navigate sURL

For i = 1 To iCount
Do
DoEvents
Loop Until ieApp.readyState = ieREADYSTATE_COMPLETE

sDate = Left(ieApp.DOCUMENT.all(lElement).innertext, 250)

If Len(sDate) > 0 Then Exit For

Next i

If Len(sDate) = 0 Then
GetRealTime = #12:00:00 AM#
Else
'get ending point of TIME
lFirstCrLf = InStr(1, sDate, vbCrLf)

GetRealTime = CDate(Left(sDate, lFirstCrLf))
End If
Set ieApp = Nothing
End Function
'/==============================/