Option Explicit
Const NEWGET = "GET <path> HTTP/1.1\n" & _
"Host: <host>\n" & _
"Accept: */*\n\n"
Private mstrLastAddress As String
Private mstrLastLocation As String
Private mstrLastURL As String
Private mstrCurrentURL As String
Private mbTextRead As Boolean
Private mstrCurrentText As String
Private mlngCurrentSize As Long
Private mlngCurrentBytes As Long
Private mlngStopPosition As Long
Private mstrLocalFile As String
Private mstrTmpExt As String
Private mintResumePosition As Long
Event Error(Message As String)
Event TextReadComplete(Text As String)
Event DownloadComplete()
Event Progress(CurrentBytes As Long, TotalBytes As Long, KBPS As Long)
Private Sub Download(URL As String, Optional StopPosition As Long = 0)
mstrLastURL = ""
mstrLastLocation = ""
mstrCurrentText = ""
mlngCurrentBytes = 0
mlngCurrentSize = 0
mlngStopPosition = StopPosition
mstrCurrentURL = URL
Winsock1.Close
Winsock1.Connect CrackURL(URL)(0), 80
End Sub
Private Sub Winsock1_Connect()
Dim strRequest As String
debugprint "Connected to " & Winsock1.RemoteHostIP
If mstrLastAddress = "" Then
strRequest = FormatHeader(NEWGET, mstrCurrentURL)
Else
strRequest = FormatHeader(NEWGET, mstrLastURL)
End If
debugprint "-------------SEND----------------------"
debugprint strRequest
Winsock1.SendData strRequest
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim intI As Integer
Dim intJ As Integer
Dim Data() As Byte
Dim strData As String
Dim strDataLn() As String
Dim strSplit() As String
Dim strSplit2() As String
Dim strFilePath As String
Winsock1.GetData Data, vbByte Or vbArray
mlngCurrentBytes = mlngCurrentBytes + bytesTotal
strData = StrConv(Data, vbUnicode)
'MsgBox strData
Form1.Caption = mlngCurrentBytes & "/" & mlngCurrentSize & " [" & mlngStopPosition & "]"
' stop on zero (only in text mode)
If mbTextRead = True And mlngCurrentSize = 0 And Right(strData, 7) = vbCrLf & "0" & vbCrLf & vbCrLf Then
RaiseEvent TextReadComplete(mstrCurrentText)
Winsock1.Close
Exit Sub
End If
' stop on size
If mbTextRead = False And (mlngCurrentSize > 0 And mlngCurrentBytes >= mlngCurrentSize) Or _
mbTextRead = True And mlngCurrentBytes >= mlngStopPosition Then
If mbTextRead Then
RaiseEvent TextReadComplete(mstrCurrentText)
Else
Put #1, LOF(1) + 1, Data
Close #1
RaiseEvent DownloadComplete
End If
Winsock1.Close
Exit Sub
End If
' if it hasnt stopped, check for http headers
If cmp(strData, "HTTP/1.1 ") Then
strDataLn = Split(strData, vbCrLf)
Do While Not cmp(strDataLn(intI), "Content-Length: ") And intI < UBound(strDataLn)
intI = intI + 1
Loop
mlngCurrentSize = Val(Trim(Replace(strDataLn(intI), "Content-Length: ", "")))
Select Case strDataLn(0)
Case "HTTP/1.1 200 OK" ' if all ok ?
MsgBox "starting transfer"
If mbTextRead Then
strData = Split(strData, vbCrLf & vbCrLf, 2)(1)
mstrCurrentText = mstrCurrentText & strData
Else
strFilePath = mstrLocalFile & mstrTmpExt
'Do While FileExists(strFilePath)
' intJ = intJ + 1
' strFilePath = mstrLocalFile & "(" & intJ & ")" & mstrTmpExt
'Loop
Open strFilePath For Binary Access Write As #1
End If
Case "HTTP/1.1 404", "HTTP/1.1 410" ' if missing file ?
RaiseEvent Error("Invalid URL or missing file")
Winsock1.Close
Case "HTTP/1.1 206" ' if resumed ok ?
strData = Split(strData, vbCrLf & vbCrLf, 2)(1)
mstrCurrentText = mstrCurrentText & strData
Case "HTTP/1.1 303", "HTTP/1.1 302" ' if redirection ?
debugprint "-------------RECV----------------------"
strSplit = Split(strData, vbCrLf)
For intI = 0 To UBound(strSplit)
debugprint strSplit(intI)
If Left$(strSplit(intI), 9) = "Location:" Then
mstrLastAddress = strSplit(intI)
strSplit2 = Split(mstrLastAddress, "/")
mstrLastAddress = strSplit2(2)
mstrLastLocation = strSplit2(3)
mstrLastURL = Trim(Replace(strSplit(intI), "Location:", ""))
End If
Next
Winsock1.Close
Winsock1.Connect mstrLastAddress, 80 ' connect to new address
Exit Sub
End Select
Else ' if we dont have http header (raw data) ?
If mbTextRead Then
mstrCurrentText = mstrCurrentText & strData
Else
Put #1, LOF(1) + 1, Data
End If
End If
End Sub
Private Sub Winsock1_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)
RaiseEvent Error(Description)
End Sub
Public Sub StartDownload(URL As String, LocalPath As String, Optional TempExtension As String = "")
Dim tmpPath As String
mstrLocalFile = LocalPath
mstrTmpExt = TempExtension
tmpPath = mstrLocalFile & mstrTmpExt
If FileExists(tmpPath) Then
mintResumePosition = FileLen(tmpPath)
End If
mbTextRead = False
Download URL
End Sub
Public Sub ReadUrl(URL As String, Optional StopPosition As Long = 0)
mbTextRead = True
Download URL, StopPosition
End Sub
Private Function cmp(ByVal s1 As String, ByVal s2 As String) As Boolean
If LCase(Left(s1, Len(s2))) = LCase(s2) Then
cmp = True
Else
cmp = False
End If
End Function
Private Function CrackURL(URL As String) As String()
On Error Resume Next
URL = Trim(Replace(URL, "http://", ""))
CrackURL = Split(URL, "/", 2)
End Function
Private Function FormatHeader(strHeader As String, URL As String) As String
On Error Resume Next
Dim tmpHeader As String
Dim strSplit() As String
strSplit = CrackURL(URL)
tmpHeader = Replace(strHeader, "\n", vbCrLf)
tmpHeader = Replace(tmpHeader, "<host>", strSplit(0))
tmpHeader = Replace(tmpHeader, "<path>", "/" & strSplit(1))
FormatHeader = tmpHeader
End Function
Private Function FileExists(fname) As Boolean
On Error Resume Next
If fname = "" Or Right(fname, 1) = "\" Then
FileExists = False
Exit Function
End If
FileExists = (Dir(fname) <> "")
End Function
Private Sub debugprint(a)
'If Len(Form1.Text1.Text) > 65000 Then Form1.Text1.Text = ""
Form1.Text1.Text = Form1.Text1.Text & vbCrLf & a
End Sub