I have a huge (15mb) Excel workbook that downloads lots of data by use of several webqueries (QueryTables). For the most part it works perfectly. A few of the queries take several minutes (like 3 or 4) to complete. I have 2 problems that I have not been able to resolve, both of which are related to the Refresh BackgroundQuery command. Number 1, if the queried website is not responding, the Refresh stays active awaiting a reply, and cannot be stopped except by crashing the workbook through the Task Manager. Number 2, the user decides to end the program manually, which cannot be done until the Refresh has completed, often times, several minutes.
I have attached a very stripped down, but completely working, version of the code. This code, if inserted in a workbook, will query one of the websites and download data. This particular webquery completes in about 30 seconds. This is normal. It probably looks like an awful lot of code, but not to worry, 99% of it is required to create the Query URL and works perfectly. The URLchanges every hour, so, if any of this code is omitted, it will not work.
Sub MAIN() is placed immediately following the public definitions. This is the starting point. It calls the functions to create this hour's URL, and then calls the function that I'm having problems with, creatively named "ProblemFunction", passing the URL in the variable "b".
Function ProblemFunction (b as string) is a very basic webquery. .Refresh BackgroundQuery is currently set to False as each query must be processed before the next one begins. This means that the program stops on the Refresh command until the query completes. Ctrl Break only works at the conclussion of a command so it has no effect on cancelling the Refresh. Likewise, testing the data cannot be done until after the Refresh, so a failed website cannot be detected.
I'm thinking that the .Refresh BackgroundQuery needs to be set to True so the program continues into some sort of "DoEvents", or "Do While .Refreshing" loop within the function, until the query completes. I know that this can be done using the .ReadyState command with the Open website method to import data, but that method takes (in many cases) 3 to 4 times longer to download. Perhaps a new Class Module needs to be added to allow a loop which can be stopped. In any case, I've used up all of my knowledge and resourses to no avail.
If someone has time to look at the code and offer some guidence, it would be greatly appreciated. (I also hope that I set up the code tags properly).
Thanks, Tom
I have attached a very stripped down, but completely working, version of the code. This code, if inserted in a workbook, will query one of the websites and download data. This particular webquery completes in about 30 seconds. This is normal. It probably looks like an awful lot of code, but not to worry, 99% of it is required to create the Query URL and works perfectly. The URLchanges every hour, so, if any of this code is omitted, it will not work.
Sub MAIN() is placed immediately following the public definitions. This is the starting point. It calls the functions to create this hour's URL, and then calls the function that I'm having problems with, creatively named "ProblemFunction", passing the URL in the variable "b".
Function ProblemFunction (b as string) is a very basic webquery. .Refresh BackgroundQuery is currently set to False as each query must be processed before the next one begins. This means that the program stops on the Refresh command until the query completes. Ctrl Break only works at the conclussion of a command so it has no effect on cancelling the Refresh. Likewise, testing the data cannot be done until after the Refresh, so a failed website cannot be detected.
I'm thinking that the .Refresh BackgroundQuery needs to be set to True so the program continues into some sort of "DoEvents", or "Do While .Refreshing" loop within the function, until the query completes. I know that this can be done using the .ReadyState command with the Open website method to import data, but that method takes (in many cases) 3 to 4 times longer to download. Perhaps a new Class Module needs to be added to allow a loop which can be stopped. In any case, I've used up all of my knowledge and resourses to no avail.
If someone has time to look at the code and offer some guidence, it would be greatly appreciated. (I also hope that I set up the code tags properly).
Thanks, Tom
Code:
'ALL PUBLIC, CONSTS AND TYPES ARE REQUIRED AND WORK. PROCEED TO Sub MAIN()
Option Explicit
Const TIME_ZONE_ID_UNKNOWN As Long = 1
Const TIME_ZONE_ID_STANDARD As Long = 1
Const TIME_ZONE_ID_DAYLIGHT As Long = 2
Const TIME_ZONE_ID_INVALID As Long = &HFFFFFFFF
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To 63) As Byte
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To 63) As Byte
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Declare Function GetTimeZoneInformation Lib "kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Public AmPmTest As Boolean
Public er As String
Public RucT(1, 8)
Public UtcOffset As Integer
'ALL CODE ABOVE THIS POINT IS REQUIRED AND WORKS PERFECTLY
Sub Main() 'START HERE. THIS QUERY WILL TAKE ABOUT 30 SECONDS TO RUN. THIS IS NORMAL.
Dim b As String 'DECLARE THE QUERY URL STRING
b = RUCtimes("LHZ") & "RR1h" 'CALL THE FUNCTION TO CREATE THE
'QUERY URL, WHICH CHANGES EVERY HOUR.
er = ProblemFunction(b) 'CALL THE WEBQUERY FUNCTION WHICH
'NEEDS TIMEOUT AND CANCEL CODE ADDED.
Sheets("S").Select 'VIEW RESULTS
'AT THIS POINT, THE QUERY DATA MUST BE PROCESSED BEFORE THE PROGRAM CONTINUES
End Sub
Function ProblemFunction(b As String) 'b is the passed URL
Dim QT As QueryTable
Application.DisplayAlerts = False 'DELETE QT DESTINATION SHEET
On Error Resume Next
Sheets("S").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add After:=Worksheets(Worksheets.Count) 'ADD NEW QT DESTINATION SHEET
ActiveSheet.Name = "S"
Set QT = Sheets("S").QueryTables.Add(Connection:=b, _
Destination:=Sheets("S").Cells(1, 1))
With QT
.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = False
End With
'REFRESH BACKGROUNDQUERY IS SET TO FALSE BECAUSE THE QUERY DATA MUST BE PROCESSED
'BY THE CALLING SUB BEFORE THE REST OF THE PROGRAM CAN CONTINUE.
'I'M THINKING THAT REFRESH BACKGROUNDQUERY SHOULD BE TRUE SO THE FUNCTION CONTINUES
'INTO SOMETHING LIKE THE FOLLOWING:
'DoEvents
'DO WHILE .REFRESHING =TRUE
'IF TIMEOUT IS REACHED OR USER CANCELS THEN
'PROBLEMFUNCTION="CANCELED"
'.CANCELREFRESH
'EXIT FUNCTION
'END IF
'LOOP
'PROBLEMFUNCTION="OK"
'OF COURSE NOTHING I'VE TRIED WORKS. PERHAPS IT NEEDS A CLASS MODULE?
End Function
'ALL CODE BELOW THIS POINT IS REQUIRED TO CALCULATE THE QUERY URL.
'THERE ARE NO PROBLEMS WITH THIS CODE
Function RUCtimes(b1 As String)
'CREATES THE URL
SunriseCalc 0, 2 'CALCULATE THE TIMES NEEDED TO FILL THE URL STRING
RUCtimes = "URL;http://rucsoundings.noaa.gov/get_soundings.cgi?airport=" & b1 _
& ";startSecs=" & RucT(0, 0) & ";endSecs=" & RucT(0, 1) & ";data_source="
End Function
Sub SunriseCalc(Ws As Integer, loc As Integer)
Dim sdata(7) As Variant
Dim Tz(7) As String
Dim Dst(2) As String
Dim b As String
Dim d8 As Date
Dim DstStart As Double
Dim DstStop As Double
Dim Sr As Double
Dim Ss As Double
Dim SrU As Double
Dim SsU As Double
Dim ttSr As Double
Dim ttSs As Double
Dim Utm As Double
Dim loc1 As Integer
Dim X As Integer
Dim Ama(2, 2)
Ama(1, 0) = "AM"
Ama(1, 1) = "PM"
Ama(0, 0) = "PM"
Ama(0, 1) = "AM"
d8 = Now()
Tz(0) = "H"
Tz(1) = "AK"
Tz(2) = "P"
Tz(3) = "M"
Tz(4) = "C"
Tz(5) = "E"
Tz(6) = "A"
Dst(0) = "S"
Dst(1) = "D"
sdata(0) = 36.017
sdata(1) = -78.333
sdata(5) = -5
sdata(2) = year(d8)
sdata(3) = month(d8)
sdata(4) = day(d8)
If sdata(2) < 2007 Then
For X = 1 To 7
If Weekday("4/" & X & "/" & sdata(2)) = 1 Then Exit For
Next
DstStart = DateValue("4/" & X & "/" & sdata(2))
For X = 31 To 23 Step -1
If Weekday("10/" & X & "/" & sdata(2)) = 1 Then Exit For
Next
DstStop = DateValue("10/" & X & "/" & sdata(2))
Else
For X = 8 To 15
If Weekday("3/" & X & "/" & sdata(2)) = 1 Then Exit For
Next
DstStart = DateValue("3/" & X & "/" & sdata(2))
For X = 2 To 8
If Weekday("11/" & X & "/" & sdata(2), vbSunday) = 2 Then Exit For
Next
DstStop = DateValue("11/" & X & "/" & sdata(2)) - 1
End If
If Int(d8) >= DstStart And Int(d8) < DstStop Then
sdata(6) = 1
Else
sdata(6) = 0
End If
Sr = Sunrise(sdata(0), sdata(1), sdata(2), sdata(3), sdata(4), sdata(5), sdata(6))
Ss = Sunset(sdata(0), sdata(1), sdata(2), sdata(3), sdata(4), sdata(5), sdata(6))
Utm = SystemTZ(AmPmTest, True)
SrU = (Sr + Int(Now()) - 1 * (Hour(Now()) > Hour(Sr) + 4)) - ((sdata(5) + sdata(6)) / 24)
ttSr = SrU + 3 / 24 - (1 * (Minute(SrU) > 20) / 24)
ttSr = Int(ttSr) + Hour(ttSr) / 24
SsU = (Ss + Int(Now()) - 1 * (Hour(Now()) > Hour(Ss) + 4)) - ((sdata(5) + sdata(6)) / 24)
ttSs = SsU + 1 / 24 - (1 * (Minute(SsU) > 20) / 24)
ttSs = Int(ttSs) + Hour(ttSs) / 24
X = (ttSr - Utm) * 24
If X < 4 Then X = 3 Else If X > 5 Then X = 5
RucT(0, 0) = (ttSr - 25569 - X / 24) * 86400
RucT(0, 1) = ((ttSr - 25569) + 1 / 24) * 86400
RucT(0, 2) = Round(24 * ((ttSr + (RucT(0, 6) + RucT(0, 7)) / 24) - (Int(Now()) + (Hour(Now()) / 24))), 0)
X = (ttSs - Utm) * 24
If X < 4 Then X = 3 Else If X > 5 Then X = 5
RucT(0, 3) = (ttSs - 25569 - X / 24) * 86400
RucT(0, 4) = ((ttSs - 25569) + 1 / 24) * 86400
RucT(0, 5) = Round(24 * ((ttSs + (RucT(0, 6) + RucT(0, 7)) / 24) - (Int(Now()) + (Hour(Now()) / 24))), 0)
End Sub
Function SystemTZ(DontLoadOnG1 As Boolean, Utc As Boolean)
Dim lRV As Long
Dim tzi As TIME_ZONE_INFORMATION
Dim tmp(2) As String
lRV = GetTimeZoneInformation(tzi)
Select Case lRV
Case 0: tmp(0) = "Cannot determine current time zone"
tmp(1) = "NONE"
Case 1: tmp(0) = tzi.StandardName
tmp(1) = "NO"
Case 2: tmp(0) = tzi.DaylightName
tmp(1) = "YES"
End Select
If InStr(tmp(0), Chr$(0)) Then tmp(0) = Left(tmp(0), InStr(tmp(0), Chr$(0)) - 1)
If Utc Then
SystemTZ = DateAdd("n", CDbl(tzi.Bias) - CDbl(tzi.DaylightBias) * (tmp(1) = "YES"), Now)
Else
SystemTZ = "LOCAL TIME = " & Left(tmp(0), 4) & "." & Mid(tmp(0), InStr(tmp(0), " "), 10) _
& (CDbl(tzi.Bias) - CDbl(tzi.DaylightBias) * (tmp(1) = "YES")) / -60
End If
UtcOffset = (CDbl(tzi.Bias) - CDbl(tzi.DaylightBias) * (tmp(1) = "YES")) / -60
RucT(0, 6) = tzi.Bias / -60
RucT(0, 7) = tzi.DaylightBias / -60
End Function
Function Sunrise(lat, lon, year, month, day, timezone, dlstime)
Dim longitude As Double, latitude As Double, JD As Double
Dim riseTimeGMT As Double, riseTimeLST As Double
longitude = lon * -1
latitude = lat
If (latitude > 89.8) Then latitude = 89.8
If (latitude < -89.8) Then latitude = -89.8
JD = calcJD(year, month, day)
riseTimeGMT = calcSunriseUTC(JD, latitude, longitude)
riseTimeLST = riseTimeGMT + (60 * timezone) + (dlstime * 60)
Sunrise = riseTimeLST / 1440
End Function
Function Sunset(lat, lon, year, month, day, timezone, dlstime)
Dim longitude As Double, latitude As Double, JD As Double
Dim setTimeGMT As Double, setTimeLST As Double
longitude = lon * -1
latitude = lat
If (latitude > 89.8) Then latitude = 89.8
If (latitude < -89.8) Then latitude = -89.8
JD = calcJD(year, month, day)
setTimeGMT = calcSunsetUTC(JD, latitude, longitude)
setTimeLST = setTimeGMT + (60 * timezone) + (dlstime * 60)
Sunset = setTimeLST / 1440
End Function
Function radToDeg(angleRad)
radToDeg = (180# * angleRad / Application.WorksheetFunction.Pi())
End Function
Function degToRad(angleDeg)
degToRad = (Application.WorksheetFunction.Pi() * angleDeg / 180#)
End Function
Function calcJD(year, month, day)
Dim A As Double, b As Double, JD As Double
If (month <= 2) Then
year = year - 1
month = month + 12
End If
A = Application.WorksheetFunction.Floor(year / 100, 1)
b = 2 - A + Application.WorksheetFunction.Floor(A / 4, 1)
JD = Application.WorksheetFunction.Floor(365.25 * (year + 4716), 1) + _
Application.WorksheetFunction.Floor(30.6001 * (month + 1), 1) + day + b - 1524.5
calcJD = JD
If month = 13 Then
month = 1
year = year + 1
End If
If month = 14 Then
month = 2
year = year + 1
End If
End Function
Function calcTimeJulianCent(JD)
Dim t As Double
t = (JD - 2451545#) / 36525#
calcTimeJulianCent = t
End Function
Function calcJDFromJulianCent(t)
Dim JD As Double
JD = t * 36525# + 2451545#
calcJDFromJulianCent = JD
End Function
Function calcGeomMeanLongSun(t)
Dim l0 As Double
l0 = 280.46646 + t * (36000.76983 + 0.0003032 * t)
Do
If (l0 <= 360) And (l0 >= 0) Then Exit Do
If l0 > 360 Then l0 = l0 - 360
If l0 < 0 Then l0 = l0 + 360
Loop
calcGeomMeanLongSun = l0
End Function
Function calcGeomMeanAnomalySun(t)
Dim m As Double
m = 357.52911 + t * (35999.05029 - 0.0001537 * t)
calcGeomMeanAnomalySun = m
End Function
Function calcEccentricityEarthOrbit(t)
Dim e As Double
e = 0.016708634 - t * (0.000042037 + 0.0000001267 * t)
calcEccentricityEarthOrbit = e
End Function
Function calcSunEqOfCenter(t)
Dim m As Double, mrad As Double, sinm As Double, sin2m As Double, sin3m As Double
Dim C As Double
m = calcGeomMeanAnomalySun(t)
mrad = degToRad(m)
sinm = Sin(mrad)
sin2m = Sin(mrad + mrad)
sin3m = Sin(mrad + mrad + mrad)
C = sinm * (1.914602 - t * (0.004817 + 0.000014 * t)) _
+ sin2m * (0.019993 - 0.000101 * t) + sin3m * 0.000289
calcSunEqOfCenter = C
End Function
Function calcSunTrueLong(t)
Dim l0 As Double, C As Double, O As Double
l0 = calcGeomMeanLongSun(t)
C = calcSunEqOfCenter(t)
O = l0 + C
calcSunTrueLong = O
End Function
Function calcSunApparentLong(t)
Dim O As Double, omega As Double, lambda As Double
O = calcSunTrueLong(t)
omega = 125.04 - 1934.136 * t
lambda = O - 0.00569 - 0.00478 * Sin(degToRad(omega))
calcSunApparentLong = lambda
End Function
Function calcMeanObliquityOfEcliptic(t)
Dim seconds As Double, e0 As Double
seconds = 21.448 - t * (46.815 + t * (0.00059 - t * (0.001813)))
e0 = 23# + (26# + (seconds / 60#)) / 60#
calcMeanObliquityOfEcliptic = e0
End Function
Function calcObliquityCorrection(t)
Dim e0 As Double, omega As Double, e As Double
e0 = calcMeanObliquityOfEcliptic(t)
omega = 125.04 - 1934.136 * t
e = e0 + 0.00256 * Cos(degToRad(omega))
calcObliquityCorrection = e
End Function
Function calcSunDeclination(t)
Dim e As Double, lambda As Double, sint As Double, theta As Double
e = calcObliquityCorrection(t)
lambda = calcSunApparentLong(t)
sint = Sin(degToRad(e)) * Sin(degToRad(lambda))
theta = radToDeg(Application.WorksheetFunction.Asin(sint))
calcSunDeclination = theta
End Function
Function calcEquationOfTime(t)
Dim epsilon As Double, l0 As Double, e As Double, m As Double
Dim Y As Double, sin2l0 As Double, sinm As Double
Dim cos2l0 As Double, sin4l0 As Double, sin2m As Double, Etime As Double
epsilon = calcObliquityCorrection(t)
l0 = calcGeomMeanLongSun(t)
e = calcEccentricityEarthOrbit(t)
m = calcGeomMeanAnomalySun(t)
Y = Tan(degToRad(epsilon) / 2#)
Y = Y ^ 2
sin2l0 = Sin(2# * degToRad(l0))
sinm = Sin(degToRad(m))
cos2l0 = Cos(2# * degToRad(l0))
sin4l0 = Sin(4# * degToRad(l0))
sin2m = Sin(2# * degToRad(m))
Etime = Y * sin2l0 - 2# * e * sinm + 4# * e * Y * sinm * cos2l0 _
- 0.5 * Y * Y * sin4l0 - 1.25 * e * e * sin2m
calcEquationOfTime = radToDeg(Etime) * 4#
End Function
Function calcHourAngleSunrise(lat, solarDec)
Dim latRad As Double, sdRad As Double, HAarg As Double, ha As Double
latRad = degToRad(lat)
sdRad = degToRad(solarDec)
HAarg = (Cos(degToRad(90.833)) / (Cos(latRad) * Cos(sdRad)) - Tan(latRad) * Tan(sdRad))
ha = (Application.WorksheetFunction.Acos(Cos(degToRad(90.833)) _
/ (Cos(latRad) * Cos(sdRad)) - Tan(latRad) * Tan(sdRad)))
calcHourAngleSunrise = ha
End Function
Function calcHourAngleSunset(lat, solarDec)
Dim latRad As Double, sdRad As Double, HAarg As Double, ha As Double
latRad = degToRad(lat)
sdRad = degToRad(solarDec)
HAarg = (Cos(degToRad(90.833)) / (Cos(latRad) * Cos(sdRad)) - Tan(latRad) * Tan(sdRad))
ha = (Application.WorksheetFunction.Acos(Cos(degToRad(90.833)) _
/ (Cos(latRad) * Cos(sdRad)) - Tan(latRad) * Tan(sdRad)))
calcHourAngleSunset = -ha
End Function
Function calcSunriseUTC(JD, latitude, longitude)
Dim t As Double, eqtime As Double, solarDec As Double, hourangle As Double
Dim delta As Double, timeDiff As Double, timeUTC As Double
Dim newt As Double
t = calcTimeJulianCent(JD)
eqtime = calcEquationOfTime(t)
solarDec = calcSunDeclination(t)
hourangle = calcHourAngleSunrise(latitude, solarDec)
delta = longitude - radToDeg(hourangle)
timeDiff = 4 * delta
timeUTC = 720 + timeDiff - eqtime
newt = calcTimeJulianCent(calcJDFromJulianCent(t) + timeUTC / 1440#)
eqtime = calcEquationOfTime(newt)
solarDec = calcSunDeclination(newt)
hourangle = calcHourAngleSunrise(latitude, solarDec)
delta = longitude - radToDeg(hourangle)
timeDiff = 4 * delta
timeUTC = 720 + timeDiff - eqtime
calcSunriseUTC = timeUTC
End Function
Function calcSunsetUTC(JD, latitude, longitude)
Dim t As Double, eqtime As Double, solarDec As Double, hourangle As Double
Dim delta As Double, timeDiff As Double, timeUTC As Double
Dim newt As Double
t = calcTimeJulianCent(JD)
eqtime = calcEquationOfTime(t)
solarDec = calcSunDeclination(t)
hourangle = calcHourAngleSunset(latitude, solarDec)
delta = longitude - radToDeg(hourangle)
timeDiff = 4 * delta
timeUTC = 720 + timeDiff - eqtime
newt = calcTimeJulianCent(calcJDFromJulianCent(t) + timeUTC / 1440#)
eqtime = calcEquationOfTime(newt)
solarDec = calcSunDeclination(newt)
hourangle = calcHourAngleSunset(latitude, solarDec)
delta = longitude - radToDeg(hourangle)
timeDiff = 4 * delta
timeUTC = 720 + timeDiff - eqtime
calcSunsetUTC = timeUTC
End Function