Option Explicit

'// FORM - INFO CLICK
Private Sub Command1_Click()
    cmdFocus.SetFocus
    Call mDownload.InitX(RemoteAgent, ConnectTry)
    Call mDownload.LoadX(RemoteHost, RemoteFile, RemotePort)
End Sub

Private Sub Command2_Click()
    cmdFocus.SetFocus
    Call mDownload.CancelX
End Sub

'// FORM - CLOSE FORM
Private Sub Form_Terminate()
    Unload Me
End Sub

'// FORM - UNLOAD FORM
Private Sub Form_Unload(Cancel As Integer)
    Call mDownload.DisconnectX
End Sub

'// FORM - WINSOCK CLOSE
Private Sub Winsock1_Close()
    Call mDownload.CloseX
End Sub

'// FORM - WINSOCK SEND DATA
Private Sub Winsock1_Connect()
    Call mDownload.ConnectX
End Sub

'// FORM - WINSOCK RECEIVE DATA
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Call mDownload.ReceiveX(bytesTotal)
End Sub

'// FORM - WINSOCK ERROR
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)
    Call mDownload.ErrorX(Description)
End Sub      

Option Explicit

Public Const RemoteHost    As String = "www.mysite.com"             ' HOST // NAME OR IP
Public Const RemoteFile    As String = "files/setup.exe"            ' PAGE // FOLDER/FILE
Public Const RemotePort    As Long = 80                             ' PORT // PORT NUMBER
Public Const RemoteAgent   As String = "VB Download"                ' AGENT
Public Const ConnectTry    As Long = 3                              ' TRIES // CONNECT ATTEMPTS

Public fWinsock As Form1

Public Sub main()
    Set fWinsock = New Form1
    Load fWinsock
    fWinsock.Show
End Sub

Option Explicit

'// DECLARATIONS
Private m_Form              As Form
Private m_Host              As String
Private m_File              As String
Private m_Port              As Long
Private m_Agent             As String
Private m_Header            As String
Private m_Data              As String
Private m_Status            As String
Private m_Length            As Long
Private m_Bytes             As Long
Private m_FreeFile          As Integer
Private m_Connected         As Boolean
Private m_Parsed            As Boolean
Private m_Retry             As Integer
Private m_Count             As Integer

'// INITIALIZE SOCKET
Public Sub InitX(ByVal sAgent As String, ByVal iRetry As Integer)
    m_Agent = sAgent: m_Retry = iRetry
End Sub

'// LOAD SOCKET
Public Sub LoadX(ByVal sHost As String, _
    ByVal sFile As String, ByVal lPort As Long)
    Dim sURL As String
    sURL = sHost: m_Host = sHost
    m_File = sFile: m_Port = lPort
    If Left(LCase(sURL), 7) = "http://" Then
        sURL = Mid(sURL, 8)
    End If
    Call DisconnectX
    Call UpdateStatus("Connecting ..")
    Call fWinsock.Winsock1.Connect(sURL, lPort)                     ' CONNECT TO HOST
End Sub

'// SOCKET CONNECTED
Public Sub ConnectX()
    Dim SendData As String
    Call UpdateStatus("Connected")
    m_Connected = True
        SendData = "GET /" & m_File & " HTTP/1.1" & vbCrLf          ' PAGE TO GET
        SendData = SendData & "Host: " & m_Host & vbCrLf            ' HOST NAME
        SendData = SendData & "User-Agent: " & m_Agent & vbCrLf     ' AGENT NAME
        SendData = SendData & "Accept: */*" & vbCrLf                ' ACCEPT ALL
        SendData = SendData & "Connection: close" & vbCrLf          ' SET CLOSE
        SendData = SendData & vbCrLf                                ' BLANK LINE
    Call fWinsock.Winsock1.SendData(SendData)                       ' SEND DATA
End Sub

'// GET SOCKET DATA
Public Sub ReceiveX(ByVal bytesTotal As Long)
    Dim tmpData As String
    On Error GoTo Err:
    '// GET DATA
    Call fWinsock.Winsock1.GetData(tmpData, vbString)
        m_Data = m_Data & tmpData
        m_Bytes = m_Bytes + bytesTotal
        '// GET THE HEADER
        If Not m_Parsed Then
            Call GetLength
        Else
        '// DOWNLOAD FILE
            Call Download
        End If
    Exit Sub
Err:
'// ERROR HANDLING
    Call UpdateStatus("Data Error")
    Call DisconnectX
    Exit Sub
End Sub

'// SOCKET ERROR
Public Sub ErrorX(ByVal Description As String)
    If m_Count < m_Retry And Not m_Connected Then
        If m_Count = 0 Then
            m_Count = 1
        Else
            m_Count = m_Count + 1
        End If
        Call InitX
        Call UpdateStatus("Connect Retry: " & m_Count)
    Else
        Call UpdateStatus("Error: " & Description)
        Call DisconnectX
    End If
End Sub

'// WINSOCK CLOSE
Public Sub CloseX()
    Dim tmpFile As String
    If State = sckClosing Then
        fWinsock.Winsock1.Close
    End If
    If State = sckClosed And m_Connected Then
        m_Header = Left$(m_Data, InStr(1, m_Data, vbCrLf & vbCrLf) + 1)
        m_Data = Mid(m_Data, InStr(1, m_Data, vbCrLf & vbCrLf) + 4)

        If GetHeaderField(m_Header, "Transfer-Encoding") = "chunked" Then
            m_Data = DecodeChunkedMessage(m_Data)
        End If
        '// CREATE FILE
        If Left$(GetHeaderField(m_Header, _
           "Content-Type"), Len("text/")) <> "text/" Then
                       
            If m_File = "" Then
                tmpFile = App.Path & "\Download" & Format(Now, "hhmmssmmddyy") & ".tmp"
            Else
                tmpFile = App.Path & "\Download" & Format(Now, "hhmmssmmddyy") & Right(m_File, 4)
            End If
            m_FreeFile = FreeFile
            Open tmpFile For Binary As #m_FreeFile
                Put #m_FreeFile, , m_Data
            FileClose
        '// DISPLAY TEXT
        Else
            fWinsock.Text1.Text = m_Data
            fWinsock.Text1.ZOrder 0
        End If
        Dim ResponseCode As String
        ResponseCode = GetResponse(m_Header)
        m_Status = ParseResponse(ResponseCode)
        '// PAGE FOUND OKAY
        If ResponseCode Like "2**" Then
            Call UpdateStatus("Download Complete")
        '// REDIRECTION
        ElseIf ResponseCode Like "3**" Then
            Call UpdateStatus("Redirection Error")
        '// PAGE NOT FOUND
        ElseIf ResponseCode Like "4**" Then
            Call UpdateStatus("Bad Request")
        '// SERVER ERROR
        ElseIf ResponseCode Like "5**" Then
            Call UpdateStatus("Server Error")
        Else
        '// GENERAL ERROR
            Call UpdateStatus("Download Error")
        End If
        Call CleanUp
    End If
End Sub

'// WINSOCK DISCONNECT
Public Sub DisconnectX()
    Call CleanUp
    fWinsock.Text1.Text = ""
    fWinsock.Text1.ZOrder 0
    fWinsock.ProgressBar1.Value = 0.01
    fWinsock.Winsock1.Close
End Sub

'// CANCEL DOWNLOAD
Public Sub CancelX()
    Call DisconnectX
    Call UpdateStatus("Download Cancelled")
End Sub

'// DOWNLOAD INFO
Private Sub Download()
    If m_Length > 0 Then
        Call UpdateProgress
        Call UpdateStatus("Downloading: " & m_Bytes & " of " & m_Length & " bytes " & _
        "(" & CInt(m_Bytes / (m_Length / 100)) & "%)")
    Else
        Call UpdateStatus("Downloading: " & m_Bytes & " bytes")
    End If
End Sub

'// CLOSE FILE
Private Sub FileClose()
    If m_FreeFile > 0 Then
        Close #m_FreeFile
        m_FreeFile = 0
    End If
End Sub

'// CLEAN UP VARS
Private Sub CleanUp()
    Call FileClose
    m_Bytes = 0
    m_Length = 0
    m_Parsed = False
    m_Connected = False
    m_Data = ""
    m_Header = ""
End Sub

'// UPDATE DOWNLOAD PROGRESS
Private Sub UpdateProgress()
    fWinsock.ProgressBar1.Value = m_Bytes / (m_Length / 100)
End Sub

'// UPDATE STATUS
Private Sub UpdateStatus(ByVal StatusType As String)
    fWinsock.Caption = StatusType
    fWinsock.StatusBar1.Panels(1).Text = Status
    fWinsock.StatusBar1.Panels(2).Text = m_Status
End Sub

Private Function ParseResponse(ByVal iCode) As String
    Select Case iCode
        Case "200": ParseResponse = "200: OK"
        Case "201": ParseResponse = "201: Created"
        Case "202": ParseResponse = "202: Accepted"
        Case "203": ParseResponse = "203: Non-Authoritative Information"
        Case "204": ParseResponse = "204: No Content"
        Case "205": ParseResponse = "205: Reset Content"
        Case "206": ParseResponse = "206: Partial Content"
        Case "300": ParseResponse = "300: Multiple Choices"
        Case "301": ParseResponse = "301: Moved Permanently"
        Case "302": ParseResponse = "302: Found"
        Case "303": ParseResponse = "303: See Other"
        Case "304": ParseResponse = "304: Not Modified"
        Case "305": ParseResponse = "305: Use Proxy"
        Case "306": ParseResponse = "306: (Unused)"
        Case "307": ParseResponse = "307:Temporary Redirect"
        Case "400": ParseResponse = "400: Bad Request"
        Case "401": ParseResponse = "401: nauthorized"
        Case "402": ParseResponse = "402: Payment Required"
        Case "403": ParseResponse = "403: Forbidden"
        Case "404": ParseResponse = "404: Not Found"
        Case "405": ParseResponse = "405: Method Not Allowed"
        Case "406": ParseResponse = "406: Not Acceptable"
        Case "407": ParseResponse = "407: Proxy Authentication Required"
        Case "408": ParseResponse = "408: Request Timeout"
        Case "409": ParseResponse = "409: Conflict"
        Case "410": ParseResponse = "410: Gone"
        Case "411": ParseResponse = "411: Length Required"
        Case "412": ParseResponse = "412: Precondition Failed"
        Case "413": ParseResponse = "413: Request Entity Too Large"
        Case "414": ParseResponse = "414: Request-URI Too Long"
        Case "415": ParseResponse = "415: Unsupported Media Type"
        Case "416": ParseResponse = "416: Requested Range Not Satisfiable"
        Case "417": ParseResponse = "417: Expectation Failed"
        Case "500": ParseResponse = "500: Internal Server Error"
        Case "501": ParseResponse = "501: Not Implemented"
        Case "502": ParseResponse = "502: Bad Gateway"
        Case "503": ParseResponse = "503: Service Unavailable"
        Case "504": ParseResponse = "504: Gateway Timeout"
        Case "505": ParseResponse = "505: HTTP Version Not Supported"
        Case Else: ParseResponse = "(Unknown)"
    End Select
End Function

'// WINSOCK STATE
Private Function Status() As String
    Select Case fWinsock.Winsock1.State
        Case sckClosed
            Status = "Closed"
        Case sckOpen
            Status = "Open"
        Case sckListening
            Status = "Listening"
        Case sckConnectionPending
            Status = "Pending"
        Case sckResolvingHost
            Status = "Resolving host"
        Case sckHostResolved
            Status = "Host resolved"
        Case sckConnecting
            Status = "Connecting"
        Case sckConnected
            Status = "Connected"
        Case sckClosing
            Status = "Closing"
        Case sckError
            Status = "Error"
    End Select
End Function

Private Function State() As String
    State = fWinsock.Winsock1.State
End Function

'// GET FILE LENGTH
Private Sub GetLength()
    Dim iPos As Integer
    Dim vHeaders As Variant
    Dim vHeader As Variant
    iPos = InStr(1, m_Data, vbCrLf & vbCrLf)
    If iPos Then
        m_Parsed = True
        m_Bytes = m_Bytes - iPos - 3
        vHeaders = Split(Left(m_Data, iPos - 1), vbCrLf)
        '// GET THE CONTENT LENGTH
        For Each vHeader In vHeaders
            If InStr(1, vHeader, "Content-Length") Then
                m_Length = CLng(Mid(vHeader, InStr(1, vHeader, " ") + 1))
                Exit For
            End If
        Next
    End If
End Sub

Private Function GetHeaderField(ByVal sHeader As String, _
    ByVal sHeaderField As String) As String
    Dim sBuff As String, iPos As Integer, sVal As String
    sVal = vbCrLf & sHeaderField & ": "
    iPos = InStr(1, sHeader, sVal) + Len(sVal)
    sBuff = Mid$(sHeader, iPos, InStr(iPos, sHeader, vbCrLf) - iPos)
    If Len(sBuff) > 0 Then
        GetHeaderField = sBuff
    End If
End Function

Private Function GetResponse(ByVal sHeader) As Integer
    Dim vCode As Variant
    vCode = Mid(sHeader, InStr(1, sHeader, " ") + 1, 3)
    If IsNumeric(vCode) Then
        GetResponse = CInt(vCode)
    End If
End Function

Private Function DecodeChunkedMessage(sMessage As String) As String
    'This is a scheme of chunked message
    '...<0 CHUNK SIZE>
    On Error Resume Next
    Dim lPos As Long, lPoe As Long
    Dim iOctets As Integer, sBuff As String
    Const CRLF_LENGTH = 2
    lPos = InStr(1, sMessage, vbCrLf)
    iOctets = Val("&H" & Left(sMessage, lPos - 1))
    Do Until iOctets = 0
        sBuff = sBuff & Mid(sMessage, lPos + CRLF_LENGTH, iOctets)
        lPoe = lPos + CRLF_LENGTH + iOctets + CRLF_LENGTH
        lPos = InStr(lPoe, sMessage, vbCrLf)
        iOctets = Val("&H" & Mid(sMessage, lPoe, lPos - lPoe))
    Loop
    DecodeChunkedMessage = sBuff
End Function