Jump to content

Lord Nikon

Members
  • Content Count

    507
  • Joined

  • Last visited

Community Reputation

0 Neutral

About Lord Nikon

  • Rank
    APH Prestige
  1. This is a usercontrol that uses the Miscrosoft Winsock control to create a virtual HTTP Client. It is like a browser only it can't change the HTML into an interactive page. To use it is quite simple you simply add a new Usercontrol to your project and use this code for it: Option Explicit Dim Host As String Dim strRequest As String Dim strIncoming As String Public LastPage As String Dim m_Cookie As String Dim strPacket As String Dim strParts() As String Dim Regex As RegExp Dim m_Match As Match Dim m_Matches As MatchCollection Private Declare Function DecompressGzipData Lib "nvrgzipd.dll" (ByVal sData As String, ByVal lDataSize As Long) As String Public Function Request(ByVal Method As String, ByVal strURL As String, Optional ByVal Referer As String = "") As String Dim iLen As Long If InStr(1, strURL, "http://") <> 0 Then Host = Mid$(strURL, 8) End If If InStr(1, Host, "?") <> 0 And Method = "POST" Then iLen = InStr(1, Host, "?") strURL = "http://" & Mid$(Host, 1, iLen - 1) strPacket = Mid$(Host, iLen + 1) End If If InStr(1, Host, "/") <> 0 Then iLen = InStr(1, Host, "/") Host = Mid$(Host, 1, iLen - 1) End If If IsMissing(Referer) = True And LastPage <> "" Then Referer = LastPage ElseIf IsMissing(Referer) = True And LastPage = "" Then Referer = "http://www.google.com/" LastPage = "http://www.google.com/" End If If UCase(Method) = "GET" Then strRequest = "GET " & strURL & " 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 _ & "Accept-Encoding: gzip, deflate" & vbCrLf _ & "Referer: " & Referer & vbCrLf _ & "Cookie: " & m_Cookie & vbCrLf _ & "Connection: close" & vbCrLf & vbCrLf Else strRequest = "POST " & strURL & " 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 _ & "Accept-Encoding: gzip, deflate" & vbCrLf _ & "Referer: " & Referer & vbCrLf _ & "Cookie: " & m_Cookie & vbCrLf _ & "Content-Type: application/x-www-form-urlencoded" & vbCrLf _ & "Content-Length: " & Len(strPacket) & vbCrLf _ & "Connection: close" & vbCrLf & vbCrLf _ & strPacket & vbCrLf End If If wsa.State <> 0 Then wsa.Close wsa.Connect Host, 80 curState.Caption = wsa.State Do Until wsa.State = 7 DoEvents Loop curState.Caption = wsa.State wsa.SendData strRequest Do Until wsa.State = 0 DoEvents Loop curState.Caption = wsa.State If strIncoming = Empty Then GoTo SendAgain strParts = Split(strIncoming, vbCrLf & vbCrLf) If GetHttpHeaderValue("Content-Encoding") = "gzip" Then Request = strParts(0) & DecompressGzip(LenB(StrConv(strParts(1), vbFromUnicode)) + 1000) ElseIf GetHttpHeaderValue("Content-Encoding") = "chunked" Then Request = strParts(0) & DecodeChunkedMessage Else Request = strIncoming End If LastPage = strURL m_Cookie = ParseCookies(strParts(0), m_Cookie) Exit Function SendAgain: Request = Request(Method, strURL, Referer) End Function Private Function DecodeChunkedMessage() As String Dim lngPosA As Long Dim lngPosB As Long Dim intOctetsToRead As Integer Dim strTempBuffer As String Const CRLF_LENGTH = 2 lngPosA = InStr(1, strParts(1), vbCrLf) intOctetsToRead = Val("&H" & Left(strParts(1), lngPosA - 1)) Do Until intOctetsToRead = 0 strTempBuffer = strTempBuffer & Mid$(strParts(1), lngPosA + CRLF_LENGTH, intOctetsToRead) lngPosB = lngPosA + CRLF_LENGTH + intOctetsToRead + CRLF_LENGTH lngPosA = InStr(lngPosB, strParts(1), vbCrLf) intOctetsToRead = Val("&H" & Mid$(strParts(1), lngPosB, lngPosA - lngPosB)) Loop DecodeChunkedMessage = strTempBuffer End Function Private Function GetHttpHeaderValue(strValueName As String) As String Dim strHeaders() As String Dim varHeaders As Variant strHeaders = Split(strParts(0), vbCrLf) For Each varHeaders In strHeaders varHeaders = LCase(varHeaders) If InStr(varHeaders, LCase(strValueName)) > 0 Then GetHttpHeaderValue = Trim$(Mid$(varHeaders, InStr(varHeaders, Chr(32)))) Exit Function End If Next End Function Private Function DecompressGzip(lngLength As Long) As String DecompressGzip = DecompressGzipData(strParts(1), lngLength) End Function Public Function ParseCookies(strHeader As String, strOldCookies As String) As String Dim udtVars() As String Dim udtVals() As String Dim strTemp As String Dim X As Long Dim strFinal As String Dim intCount As Long Dim strSource As String: strSource = strHeader & strOldCookies Set Regex = New RegExp Regex.Global = True Regex.IgnoreCase = True Regex.MultiLine = True Regex.Pattern = "Set-Cookie:\s*(.+?)=(.+?);" strOldCookies = "Set-Cookie: " & strOldCookies Set m_Matches = Regex.Execute(strSource) For Each m_Match In m_Matches Set m_Match = m_Matches(intCount) strTemp = strTemp & m_Match.SubMatches(0) & vbCrLf intCount = intCount + 1 Next udtVars = Split(strTemp, vbCrLf) strTemp = "" intCount = 0 Set m_Matches = Regex.Execute(strSource) For Each m_Match In m_Matches Set m_Match = m_Matches(intCount) strTemp = strTemp & m_Match.SubMatches(1) & vbCrLf intCount = intCount + 1 Next udtVals = Split(strTemp, vbCrLf) For X = 0 To UBound(udtVars) - 1 If InStr(1, strFinal, udtVars(X)) = 0 Then strFinal = strFinal & udtVars(X) & "=" & udtVals(X) & ";" End If Next X ParseCookies = strFinal End Function Private Sub wsa_Close() curState.Caption = wsa.State wsa.Close End Sub Private Sub wsa_Connect() curState.Caption = wsa.State strIncoming = "" End Sub Private Sub wsa_DataArrival(ByVal bytesTotal As Long) Dim Data As String wsa.GetData Data, vbString strIncoming = strIncoming & Data End Sub How to use: This is to use the GET command to retrieve the page source of google.ca Private Sub Command1_Click() Text1.Text = HTTP.Request("GET", "http://www.google.ca/", HTTP.LastPage) End Sub This is to use the POST command to retrieve a login action on the APH forums: Private Sub Command1_Click() Text1.Text = HTTP.Request("POST", "http://www.aphnetworks.com/forums/index.php?act=Login&CODE=01?referer=&UserName=lord+nikon&PassWord=password&CookieDate=1", "http://www.aphnetworks.com/forums/index.php?act=Login&CODE=00") End Sub The wrapper doesn't have all the fancy features but it's still very fast and convenient. Credits goto xx_WLT_xx' GZip library and his 2 other functions. You don't have to have GZip either you can easily take GZip out. Enjoy
×
×
  • Create New...