Public Sub Pause(Length As Double)
Dim StartTime
StartTime = Timer
Do While Timer - StartTime < Length
DoEvents
Loop
End Sub
---------------------------------------------------------------
Private Sub cmdGet_Click()
txtBuffer.Text = ""
Wsck1.Close
Wsck1.Connect "wunderground.com", 80
End Sub
---------------------------------------------------------------
Private Sub Wsck1_Close()
Dim Str1 As String, Str2 As String, Str3 As String
On Error GoTo Weather_Error
Pause 0.5
Wsck1.Close
Wsck1.Tag = "CLOSED"
If txtBuffer.Text <> "" Then txtBuffer.Text = Mid(txtBuffer.Text, InStr(txtBuffer.Text, "<"), Len(txtBuffer.Text))
'Location
Str1 = Mid(txtBuffer.Text, InStr(txtBuffer.Text, "<title>Weather Underground: ") + 28, Len(txtBuffer.Text))
Str1 = Mid(Str1, 1, InStr(Str1, " Forecast</title>") - 1)
txtLocation = Str1
'Temperature
Str1 = Mid(txtBuffer.Text, InStr(txtBuffer.Text, "<tr BGCOLOR=#FFFFFF><td>Temperature</td>") + 68, Len(txtBuffer.Text))
Str1 = Mid(Str1, 1, InStr(Str1, "</b> °F") - 1)
txtTemperature = Str1 & "°"
'Conditions
Str1 = Mid(txtBuffer.Text, InStr(txtBuffer.Text, "<tr BGCOLOR=#FFFFFF><td>Conditions</td>") + 47, Len(txtBuffer.Text))
Str1 = Mid(Str1, 1, InStr(Str1, "</b></td></tr>") - 1)
txtCond = Str1
'Humudity
Str1 = Mid(txtBuffer.Text, InStr(txtBuffer.Text, "<tr BGCOLOR=#FFFFFF><td>Humidity</td>") + 45, Len(txtBuffer.Text))
Str1 = Mid(Str1, 1, InStr(Str1, "%</b></td></tr>") - 1)
txtHumidity = Str1 & "%"
Exit Sub
Weather_Error:
MsgBox "Weather unavailable, try again", vbInformation, "Winsock Error"
End Sub
---------------------------------------------------------------
Private Sub Wsck1_Connect()
Wsck1.Tag = "OPEN"
Wsck1.SendData "GET [url]http://www.wunderground.com/cgi-bin/findweather/getForecast?query=[/url]" & txtZip & " HTTP/1.0" + vbCrLf + "Accept: */*" + vbCrLf + "Accept: text/html" + vbCrLf + vbCrLf
End Sub
---------------------------------------------------------------
Private Sub Wsck1_DataArrival(ByVal bytesTotal As Long)
Dim Buffer As String
If Wsck1.Tag = "OPEN" Then Wsck1.GetData Buffer
txtBuffer.Text = txtBuffer.Text + Buffer
End Sub
---------------------------------------------------------------
Private Sub Wsck1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Weather unavailable, try again", vbInformation, "Winsock Error"
End Sub