API tools faq
paste
AlexK

WinInet

AlexK
Jan 9th, 2013
9,813
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 9.37 KB | None | 0 0
raw download clone embed print report
  1. *usage;
  2. Dim r As THTTPResponse
  3. r = HTTPOperation(eHTTPGet, eHttps, "google.com", "/search", "q=beer")
  4.  
  5. Debug.Print r.lngCode
  6. Debug.Print StrConv(r.abData, vbUnicode)
  7.  
  8. *in a module
  9. Option Explicit
  10.  
  11. Public Const HTTP_OK                        As Long = 200&
  12.  
  13. Private Const HTTP_VERSION                  As String * 8 = "HTTP/1.1"
  14. Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0
  15.  
  16. Private Const INTERNET_SERVICE_HTTP         As Long = 3
  17.  
  18. Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000
  19. Private Const INTERNET_FLAG_NO_CACHE_WRITE  As Long = &H4000000
  20. Private Const INTERNET_FLAG_SECURE          As Long = &H800000
  21.  
  22. Private Const INTERNET_DEFAULT_HTTP_PORT   As Long = 80
  23. Private Const INTERNET_DEFAULT_HTTPS_PORT  As Long = 443
  24.    
  25. Private Const BUFF_LEN                      As Long = 512&
  26. Private Const DUMMY_BUFF_MULTIPLIER         As Long = 4
  27.  
  28. Private Const HTTP_ADDREQ_FLAG_ADD          As Long = &H20000000
  29. Private Const HTTP_ADDREQ_FLAG_REPLACE      As Long = &H80000000
  30. Private Const HTTP_QUERY_CONTENT_LENGTH     As Long = 5
  31. Private Const HTTP_QUERY_STATUS_CODE        As Long = 19
  32. Private Const HTTP_QUERY_STATUS_TEXT        As Long = 20
  33.  
  34. Private Const HTTP_HEADER_UTF8              As String = "Content-Type: application/x-www-form-urlencoded; charset=""UTF-8""" & vbCrLf
  35. Private Const HTTP_HEADER_UTF8_PLAIN        As String = "Content-Type: text/html; charset=""UTF-8""" & vbCrLf
  36.  
  37. Public Type THTTPResponse
  38.     strCode    As String
  39.     abData()   As Byte
  40.     lngSizeOf  As Long
  41.     lngCode    As Long
  42.     strError   As String
  43. End Type
  44.  
  45. Public Enum eHttpVerb
  46.     eHTTPpost
  47.     eHTTPGet
  48. End Enum
  49.  
  50. Public Enum eHttpPort
  51.    eHttp = INTERNET_DEFAULT_HTTP_PORT
  52.    eHttps = INTERNET_DEFAULT_HTTPS_PORT
  53. End Enum
  54.  
  55. Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
  56. Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal lpstrServerName As String, ByVal nProxyPort As Integer, ByVal lpstrUsername As String, ByVal lpstrPassword As String, ByVal dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
  57. Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hInternetSession As Long, ByVal lpstrVerb As String, ByVal lpstrObjectName As String, ByVal lpstrVersion As String, ByVal lpstrReferer As String, ByVal lpstrAcceptTypes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
  58. Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Integer
  59. Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal sOptional As String, ByVal lOptionalLength As Long) As Boolean
  60. Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef strBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Long
  61. Private Declare Function InternetReadFileBinary Lib "wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
  62. Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
  63. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
  64.  
  65. Public Function HTTPOperation(eVerb As eHttpVerb, ePort As eHttpPort, strHost As String, strObjectPath As String, strQueryString As String) As THTTPResponse
  66.  
  67. Dim HCONNECT                    As Long
  68. Dim HREQUEST                    As Long
  69. Dim HOPEN                       As Long
  70. Dim HSEND                       As Long
  71.  
  72. Dim strVerb                     As String
  73. Dim strTargetURL                As String
  74. Dim strBuff                     As String * BUFF_LEN
  75. Dim abytReadBuffFixed(BUFF_LEN) As Byte
  76. Dim abytReadBuff()              As Byte
  77. Dim bDoLoop                     As Boolean
  78. Dim lngPtrBuff                  As Long
  79. Dim sngDlTimer                  As Single
  80. Dim lNumberOfBytesRead          As Long
  81. Dim bRet                        As Boolean
  82. Dim lngTotalBytesRead           As Long
  83. Dim lngContentLen               As Long
  84.  
  85. On Error GoTo ERR_DL
  86.  
  87. strVerb = IIf(eVerb = eHTTPpost, "POST", "GET")
  88.  
  89. If (eVerb = eHTTPGet) Then
  90.     strVerb = "GET"
  91.     If (strQueryString <> "") Then strTargetURL = strObjectPath & "?" & strQueryString
  92. Else
  93.     strVerb = "POST"
  94.     strTargetURL = strObjectPath
  95. End If
  96.  
  97. HOPEN = InternetOpen(HTTPGetUAString(), INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
  98. If (HOPEN = 0) Then Err.Raise vbObjectError + 1000, "InternetOpen()", "Failed to open an Internet connection"
  99.  
  100. HCONNECT = InternetConnect(HOPEN, strHost, ePort, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0&, 0&)
  101. If (HCONNECT = 0) Then Err.Raise vbObjectError + 1001, "InternetConnect()", "Failed to open an Internet connection (ii)"
  102.  
  103. HREQUEST = HttpOpenRequest(HCONNECT, strVerb, strTargetURL, HTTP_VERSION, vbNullString, 0&, IIf(ePort = eHttps, INTERNET_FLAG_SECURE, 0) Or (INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD), 0&)
  104. If (HREQUEST = 0) Then Err.Raise vbObjectError + 1002, "HttpOpenRequest()", "Failed to open HTTP request"
  105.  
  106. If (eVerb = eHTTPpost) Then
  107.     Call HttpAddRequestHeaders(HREQUEST, HTTP_HEADER_UTF8, Len(HTTP_HEADER_UTF8), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
  108.     HSEND = HttpSendRequest(HREQUEST, vbNullChar, 0&, strQueryString, Len(strQueryString))
  109. Else
  110.     Call HttpAddRequestHeaders(HREQUEST, HTTP_HEADER_UTF8_PLAIN, Len(HTTP_HEADER_UTF8_PLAIN), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
  111.     HSEND = HttpSendRequest(HREQUEST, vbNullChar, 0&, vbNullChar, 0&)
  112. End If
  113.  
  114. If (HSEND = 0) Then Err.Raise vbObjectError + 1003, "HttpSendRequest()", "Failed to send HTTP Request"
  115.  
  116. HTTPOperation = HTTPGetResponse(HREQUEST)
  117.  
  118. If (HTTPOperation.lngCode <> HTTP_OK) Then Err.Raise vbObjectError + 1501, "HTTPGetResponse()", "HTTP Error, Code: " & HTTPOperation.lngCode & ": " & HTTPOperation.strCode
  119.  
  120. '//get data size
  121. Call HttpQueryInfo(HREQUEST, HTTP_QUERY_CONTENT_LENGTH, ByVal strBuff, BUFF_LEN, 0&)
  122.  
  123. lngContentLen = Val(strBuff)
  124. If (lngContentLen = 0&) Then lngContentLen = (BUFF_LEN * DUMMY_BUFF_MULTIPLIER)
  125.  
  126. '//chunk read the object
  127. bDoLoop = True
  128. lngPtrBuff = VarPtr(abytReadBuffFixed(0))
  129. sngDlTimer = Timer()
  130.  
  131. While bDoLoop
  132.     bRet = InternetReadFileBinary(HREQUEST, ByVal lngPtrBuff, BUFF_LEN, lNumberOfBytesRead)
  133.    
  134.     If Not bRet Then Err.Raise vbObjectError + 1500, "InternetReadFileBinary()", "An Error occured reading from the URL"
  135.  
  136.     If (lNumberOfBytesRead > 0) Then
  137.         lngTotalBytesRead = (lngTotalBytesRead + lNumberOfBytesRead)
  138.  
  139.         ReDim Preserve abytReadBuff(lngTotalBytesRead - 1)
  140.         CopyMemory abytReadBuff(lngTotalBytesRead - lNumberOfBytesRead), abytReadBuffFixed(0), lNumberOfBytesRead
  141.        
  142.         Debug.Print "READ " & lngTotalBytesRead
  143.     Else
  144.         bDoLoop = False
  145.     End If
  146. Wend
  147.  
  148. HTTPOperation.abData = abytReadBuff
  149. If (lngTotalBytesRead > 0) Then HTTPOperation.lngSizeOf = UBound(abytReadBuff) + 1
  150.  
  151. GoSub L_CLOSEH
  152. Exit Function
  153.  
  154. L_CLOSEH:
  155.     Call InternetCloseHandle(HREQUEST)
  156.     Call InternetCloseHandle(HOPEN)
  157.     Call InternetCloseHandle(HSEND)
  158.     Call InternetCloseHandle(HCONNECT)
  159.     Return
  160.    
  161. ERR_DL:
  162.     HTTPOperation.strError = Err.Description & " (" & Err.Source & ", Code: " & Hex(Err.Number) & ")"
  163.     GoSub L_CLOSEH
  164.     Err.Raise Err.Number, Err.Source, HTTPOperation.strError
  165. End Function
  166.  
  167. Private Function HTTPGetUAString() As String
  168. HTTPGetUAString = App.EXEName & "/" & App.Major & "." & App.Minor & "." & App.Revision & " (N; en-GB; DAEMON)"
  169. End Function
  170.  
  171. Public Function HTTPEncode(strRawData As String) As String
  172. Dim strChar     As String
  173. Dim strBuff     As String
  174. Dim lngChar    As Long
  175. Dim abytChar() As Byte
  176.  
  177. abytChar = StrConv(strRawData, vbFromUnicode)
  178.  
  179. For lngChar = 0 To UBound(abytChar)
  180.     Select Case abytChar(lngChar)
  181.         Case 96 To 123: strChar = ChrW$(abytChar(lngChar))
  182.         Case 64 To 91:  strChar = ChrW$(abytChar(lngChar))
  183.         Case 47 To 58:  strChar = ChrW$(abytChar(lngChar))
  184.         Case Else
  185.             strChar = (Hex(abytChar(lngChar)))
  186.             If (abytChar(lngChar) < 16) Then
  187.                 strChar = "%0" + strChar
  188.             Else
  189.                 strChar = "%" + strChar
  190.             End If
  191.     End Select
  192.     strBuff = strBuff + strChar
  193. Next
  194. HTTPEncode = strBuff
  195. End Function
  196.  
  197. Private Function HTTPGetResponse(hOpenHTTPRequest As Long) As THTTPResponse
  198. Dim strBuff     As String * BUFF_LEN&
  199. Dim lngBufflen As Long
  200.  
  201. lngBufflen = BUFF_LEN
  202.  
  203. With HTTPGetResponse
  204.     Call HttpQueryInfo(hOpenHTTPRequest, HTTP_QUERY_STATUS_TEXT, ByVal strBuff, lngBufflen, 0&)
  205.     .strCode = Left$(strBuff, lngBufflen)
  206.    
  207.     lngBufflen = BUFF_LEN
  208.     Call HttpQueryInfo(hOpenHTTPRequest, HTTP_QUERY_STATUS_CODE, ByVal strBuff, lngBufflen, 0&)
  209.     .lngCode = Val(Left$(strBuff, lngBufflen))
  210.     .strCode = "[" & .lngCode & "] " & .strCode
  211.  
  212.     If (.lngCode = 0&) Then .strCode = "[Bad/Unknown Response]"
  213. End With
  214. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!