I want to change my system time date each time an A97 app is
started. Here's how I've been doing it. Am looking for a better
way. Sure some of you have researched this.
Function SnatchInterNETTD():
'************************************************* **********************
' Internet lookup used to retrieve correct time and date.
' Remove instances of "FUCKING". I could not make this
' post stick unless I changed eBay to eFUCKINGBay. Sorry
' for the inconvenience to all readers on this forum.
'************************************************* **********************
On Error GoTo Err_SnatchInterNETTD
Dim msXML As Object, strPageContent As String, MyURL As String
Set msXML = CreateObject("Microsoft.XMLHTTP")
time/month/day, but not year!
MyURL =
"http://cgi1.eFUCKINGbay.com/aw-cgi/eFUCKINGBayISAPI.dll?TimeShow&hc=1&hm=td.s5ddl7437 "
msXML.Open "GET", MyURL, False
msXML.send
strPageContent = msXML.responseText
Set msXML = Nothing
Dim DTFacts As String, TimePart As String, DatePart As String,
StartStr As String, EndStr As String, _
StartLocn As Long, EndLocn As Long, RevisedDatePart As String,
RevisedTimePart As String
StartStr = "The official eFUCKINGBay Time is now:"
EndStr = "PDT</b></p>"
StartLocn = InStr(1, strPageContent, StartStr)
EndLocn = InStr(1, strPageContent, EndStr)
If StartLocn = 0 Or EndLocn = 0 Then
DTFacts = "eFUCKINGBay has changed the code on their time server
found at the following URL:" & CRLF & CRLF
DTFacts = DTFacts &
"http://cgi1.eFUCKINGBay.com/aw-cgi/eFUCKINGBayISAPI.dll?TimeShow&hc=1&hm=td.s5ddl7437 "
MsgBox DTFacts, 64, "URL Changed -OR- Not Found - " & MyApp$ & ",
rev. " & MY_VERSION$
Exit Function
End If
DTFacts = Mid$(strPageContent, StartLocn + 40, EndLocn - StartLocn -
37) 'Should get something like "Sunday, Oct 02, 2005 15:59:22 PDT"
Debug.Print DTFacts
DatePart = left$(DTFacts, Len(DTFacts) - 13)
'Something like Sunday, Oct 02, 2005
RevisedDatePart = right$(DatePart, 12)
'Something like Oct 02, 2005
TimePart = left$(right$(DTFacts, 12), 8)
'Something like 17:27:38
RevisedTimePart = PadWithZeros(Trim$(CStr(Val(left$(TimePart, 2)) +
3)), 2, "left") & right$(TimePart, 6) 'Something like 17:27:38
Debug.Print DatePart
Debug.Print TimePart
Date = DateValue(RevisedDatePart)
Time = TimeValue(RevisedTimePart)
SnatchInterNETTD = DTFacts
Exit_SnatchInterNETTD:
Exit Function
Err_SnatchInterNETTD:
If Err = -2146697211 Then
MsgBox "Check to see if your InterNET connection is down.",
48, "Unexpected Error - " & MyApp$ & ", rev. " & MY_VERSION$
Set msXML = Nothing
Exit Function
End If
Dim r As String, k As String, Message3 As String
r = "The following unexpected error occurred in FN
SnatchInterNETTD in Harvell module."
k = CRLF & CRLF & str$(Err) & ": " & Quote & Error$ & Quote
Message3 = r & k
MsgBox Message3, 48, "Unexpected Error - " & MyApp$ & ", rev. " &
MY_VERSION$
Resume Exit_SnatchInterNETTD
End Function
Function PadWithZeros(String2Bpadded As String, TargetLen As Integer,
RL As String)
'************************************************* ******
' Accepts String2Bpadded (a numeric string), TargetLen
' and RL ("left" or "right").
'
' Returns String2Bpadded padded on left side with zeros
' to make it a specified length (TargetLen).
'************************************************* ******
On Error GoTo Err_PadWithZeros
Dim MyLen As Integer, HowMuchPadding As Integer, i As Integer, Padding
As String, MyMsg As String
MyLen = Len(Trim$(String2Bpadded))
HowMuchPadding = TargetLen - MyLen
If HowMuchPadding < 0 Then
MyMsg = "Your source string is already longer than the target
length to which you wish to pad it out to."
MsgBox MyMsg, 48, "Can't Pad This String - " & MyApp$ & ", rev. "
& MY_VERSION$
Exit Function
End If
For i = 1 To HowMuchPadding
Padding = Padding & "0"
Next i
Select Case RL
Case "Left"
PadWithZeros = Padding & Trim$(String2Bpadded)
Case "Right"
PadWithZeros = Trim$(String2Bpadded) & Padding
End Select
Exit_PadWithZeros:
Exit Function
Err_PadWithZeros:
Dim r As String, k As String, Message3 As String
r = "The following unexpected error occurred in global Function
PadWithZeros."
k = CRLF & CRLF & str$(Err) & ": " & Quote & Error$ & Quote
Message3 = r & k
MsgBox Message3, 48, "Unexpected Error - " & MyApp$ & ", rev. " &
MY_VERSION$
Resume Exit_PadWithZeros
End Function
