Winsock HTTPWrapper

**sockopen** · 02-07-2006

Code:

Option Explicit
Const m_def_LastPage = ""
Const m_def_Cookies = ""
Const m_def_ProxyPort = ""
Const m_def_Pr******* = ""

Dim m_LastPage As String
Dim m_Cookies As String
Dim m_ProxyPort As String
Dim m_Pr******* As String

Dim strCookieBuffer() As typeCookieStore
Dim lnCookieCount As Long
Private m_hMod As Long
Private strBuffer As String
Private UseProxy As Boolean

Private Type typeCookieStore
    CookieIdentifier As String
    CookieValue As String
End Type

Public Property Get LastPage() As String
    LastPage = m_LastPage
End Property

Public Property Let LastPage(ByVal New_LastPage As String)
    m_LastPage = New_LastPage
    PropertyChanged "LastPage"
End Property

Public Property Get Pr*******() As String
     Pr******* = m_Pr*******
End Property

Public Property Let Pr*******(ByVal New_Pr******* As String)
    m_Pr******* = New_Pr*******
    PropertyChanged "Pr*******"
End Property

Public Property Get ProxyPort() As String
     ProxyPort = m_ProxyPort
End Property

Public Property Let ProxyPort(ByVal New_ProxyPort As String)
    m_ProxyPort = New_ProxyPort
    PropertyChanged "ProxyPort"
End Property

Public Property Get Cookies() As String
    Cookies = m_Cookies
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Pr******* = PropBag.ReadProperty("Pr*******", m_def_Pr*******)
    m_ProxyPort = PropBag.ReadProperty("ProxyPort", m_def_ProxyPort)
    m_LastPage = PropBag.ReadProperty("LastPage", m_def_LastPage)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Pr*******", m_Pr*******, m_def_Pr*******)
    Call PropBag.WriteProperty("ProxyPort", m_ProxyPort, m_def_ProxyPort)
    Call PropBag.WriteProperty("LastPage", m_LastPage, m_def_LastPage)
End Sub

Private Sub UserControl_InitProperties()
    m_LastPage = m_def_LastPage
    m_ProxyPort = m_def_ProxyPort
    m_Pr******* = m_def_Pr*******
End Sub

Private Sub UserControl_Initialize()
    lnCookieCount = -1
End Sub

Private Sub UserControl_Resize()
    UserControl.Width = 2000
    UserControl.Height = 2500
End Sub

Private Function DecodeChunkedMessage(ByVal strBody As String) As String
    Dim lnSize As Long, lnStart As Long, lnEnd As Long, strTemp As String
    lnStart = InStr(1, strBody, vbCrLf) - 1
    lnSize = Val("&H" & (Mid$(strBody, 1, lnStart)))
    lnStart = lnStart + 3
    Do Until lnSize = 0
        strTemp = strTemp & Mid$(strBody, lnStart, lnSize)
        lnStart = lnStart + lnSize + 2
        lnEnd = InStr(lnStart + 1, strBody, vbCrLf)
        If lnEnd = 0 Then Exit Do
        lnSize = Val("&H" & Mid$(strBody, lnStart, lnEnd - lnStart))
        lnStart = lnEnd + 2
    Loop
    DecodeChunkedMessage = strTemp
End Function

Private Function ParseCookies(ByVal strHeaders As String, strOldCookies As String) As String
    
    Dim lnTemp(1) As Long, strKey As String, strValue As String, strTempHeaders As String, strTemp As String
    strOldCookies = "; " & strOldCookies
    Do Until InStrB(1, strHeaders, "Set-Cookie", vbTextCompare) = 0
        lnTemp(0) = InStr(1, strHeaders, "Set-Cookie: ") + Len("Set-Cookie: ")
        lnTemp(1) = InStr(lnTemp(0), strHeaders, "=")
        strKey = Mid$(strHeaders, lnTemp(0), lnTemp(1) - lnTemp(0))
        
        lnTemp(0) = InStr(1, strHeaders, "Set-Cookie: " & strKey & "=") + Len("Set-Cookie: " & strKey & "=")
        lnTemp(1) = InStr(lnTemp(0), strHeaders, ";")
        strValue = Mid$(strHeaders, lnTemp(0), lnTemp(1) - lnTemp(0))
        strHeaders = Mid$(strHeaders, lnTemp(1) + Len(strValue))
        
        If InStrB(1, strOldCookies, "; " & strKey & "=", vbTextCompare) <> 0 Then
            lnTemp(0) = InStr(1, strOldCookies, "; " & strKey & "=") + Len("; " & strKey & "=")
            lnTemp(1) = InStr(lnTemp(0), strOldCookies, ";")
            strTemp = Mid$(strOldCookies, lnTemp(0), lnTemp(1) - lnTemp(0))
            strOldCookies = Replace(strOldCookies, strKey & "=" & strTemp & ";", strKey & "=" & strValue & ";")
        Else
            strOldCookies = strOldCookies & strKey & "=" & strValue & "; "
        End If
    Loop
    ParseCookies = Mid$(strOldCookies, 3)
End Function

Public Function SortHeaders(strMethod As String, URL As String, referer As String) As String
    Dim Host As String, postData As String, lnStart As Long
    If strMethod = "POST" Then
        If InStrB(1, URL, "?") <> 0 Then
            postData = Mid(URL, InStr(1, URL, "?") + 1)
            URL = Mid$(URL, 1, lnStart - 1)
        Else
            postData = ""
        End If
    End If
    If InStrB(1, URL, "https://") <> 0 Then Host = Mid$(URL, 8)
    If InStrB(1, Host, "/") <> 0 Then Host = Mid$(Host, 1, InStr(1, Host, "/") - 1)
    If InStrB(1, Host, "?") <> 0 Then Host = Mid$(Host, 1, InStr(1, Host, "?") - 1)
    If Mid$(Host, 1, 4) = "www." Then Host = Mid$(Host, 5)
    If strMethod = "POST" Then
        SortHeaders = strMethod & " " & URL & " HTTP/1.1" & vbCrLf _
        & "Host: " & Host & vbCrLf _
        & "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.7.7) Gecko/20050414 Firefox/1.0.3" & vbCrLf _
        & "Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" & vbCrLf _
        & "Accept-Language: en-us,en;q=0.5" & vbCrLf _
        & "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7" & vbCrLf _
        & "Referer: " & referer & vbCrLf _
        & "Cookie: " & m_Cookies & vbCrLf _
        & "Content-Type: application/x-www-form-urlencoded" & vbCrLf _
        & "Content-Length: " & Len(postData) & vbCrLf _
        & "Connection: close" & vbCrLf & vbCrLf _
        & postData & vbCrLf
    Else
        SortHeaders = strMethod & " " & URL & " HTTP/1.1" & vbCrLf _
        & "Host: " & Host & vbCrLf _
        & "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.7.7) Gecko/20050414 Firefox/1.0.3" & vbCrLf _
        & "Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" & vbCrLf _
        & "Accept-Language: en-us,en;q=0.5" & vbCrLf _
        & "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7" & vbCrLf _
        & "Referer: " & referer & vbCrLf _
        & "Cookie: " & m_Cookies & vbCrLf _
        & "Connection: close" & vbCrLf & vbCrLf
    End If
End Function

Private Sub Winsock_Close()
    Winsock.Close
End Sub

Private Sub Winsock_Connect()
    strBuffer = ""
End Sub

Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
    If blnStopWrapper = True Then
        Winsock.Close
        Exit Sub
    End If
    Winsock.GetData strData, vbString
    strBuffer = strBuffer & strData
End Sub

Public Sub LoadCookies(strIdentifier As String)
    Dim lnForx As Long
    For lnForx = 0 To lnCookieCount
        If LCase(strCookieBuffer(lnForx).CookieIdentifier) = LCase(strIdentifier) Then
            m_Cookies = strCookieBuffer(lnForx).CookieValue
            Exit Sub
        End If
    Next lnForx
End Sub

Public Sub SaveCookies(strIdentifier As String)
    Dim lnForx As Long
    If lnCookieCount = -1 Then GoTo RedimBuffer
    For lnForx = 0 To lnCookieCount
        If LCase(strCookieBuffer(lnForx).CookieIdentifier) = LCase(strIdentifier) Then
            strCookieBuffer(lnForx).CookieValue = m_Cookies
            Exit Sub
        End If
    Next lnForx
RedimBuffer:
    lnCookieCount = lnCookieCount + 1
    ReDim Preserve strCookieBuffer(lnCookieCount)
    strCookieBuffer(lnCookieCount).CookieIdentifier = strIdentifier
    strCookieBuffer(lnCookieCount).CookieValue = m_Cookies
End Sub

Public Function GetHeaderFieldValue(ByVal strHeaders As String, ByVal strHeader As String) As String
    Dim lnStart As Long, lnEnd As Long
    If InStrB(1, strHeaders, strHeader, vbTextCompare) <> 0 Then
        lnStart = InStr(1, strHeaders, strHeader, vbTextCompare) + Len(strHeader) + 2
        GetHeaderFieldValue = Mid$(strHeaders, lnStart, InStr(lnStart, strHeaders, vbNewLine, vbTextCompare) - lnStart)
    Else
        GetHeaderFieldValue = vbNullString
    End If
End Function

Public Sub SetProxy(strHost As String, strPort As Long)
    UseProxy = True
    m_Pr******* = strHost
    m_ProxyPort = strPort
End Sub

Public Sub NoProxy()
    UseProxy = False
End Sub

Public Sub ClearCookies()
    m_Cookies = ""
End Sub

Public Sub IdentifyAs(ByVal BrowserName As String)
    Browser = BrowserName
End Sub

Public Function StripHeaders(strHTML As String) As String
    Dim strParts() As String
    strParts = Split(strHTML, vbCrLf & vbCrLf, 2)
    StripHeaders = strParts(1)
End Function

Public Function DownloadFile(URL As String, Path As String)
    Dim FileNum As Integer, strHTML As String
    If CheckForFile(Path) = True Then
        Kill Path
    End If
    FileNum = FreeFile
    strHTML = StripHeaders(Request(URL, LastPage))
    Open Path For Output As FileNum
        Print #FileNum, strHTML
    Close FileNum
End Function

Public Function DownloadToPictureBox(URL As String, picControl As PictureBox)
    Dim sTempFile As String, sTempPath As String, sTempName As String, FileNum As Integer
    FileNum = FreeFile
    sTempFile = StripHeaders(URL)
    sTempName = "\sockopen.jpg"
    sTempPath = Environ$("TEMP") & sTempName
    Open sTempPath For Output As FileNum
        Print #FileNum, sTempFile
    Close FileNum
    picControl.Picture = LoadPicture(sTempPath)
End Function

Public Function Request(URL As String, Optional referer As String)
    If IsMissing(referer) Then referer = LastPage
    Dim Host As String, lnStart As Long, lnEnd As Long, RequestHeaders As String
    If InStrB(1, URL, "https://") <> 0 Then Host = Mid$(URL, 8)
    If InStrB(1, Host, "/") <> 0 Then Host = Mid$(Host, 1, InStr(1, Host, "/") - 1)
    If InStrB(1, Host, "?") <> 0 Then
        Host = Mid$(Host, 1, InStr(1, Host, "?") - 1)
        strMethod = "POST"
    Else
        strMethod = "GET"
    End If
    RequestHeaders = SortHeaders(strMethod, URL, referer)
    If Winsock.State <> 0 Then Winsock.Close
    strBuffer = ""
    If UseProxy = False Then
        Winsock.Connect Host, 80
    Else
        Winsock.Connect m_Pr*******, m_ProxyPort
    End If
    Do Until Winsock.State = 7: DoEvents: Loop
    Winsock.SendData RequestHeaders
    Do Until Winsock.State = 0: DoEvents: Loop
    LastPage = URL
    Dim strParts() As String
    strParts = Split(strBuffer, vbCrLf & vbCrLf)
    m_Cookies = ParseCookies(strParts(0), m_Cookies)
    If GetHeaderFieldValue(strParts(0), "Transfer-Encoding") = "chunked" Then
        strParts(1) = DecodeChunkedMessage(strParts(1))
    End If
    Request = strParts(0) & vbNewLine & vbNewLine & strParts(1)
End Function