核心代码：
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const RESPONSE_LENGTH = 1024
'Initializes an application's use of the Win32 Internet functions.
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
Private Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
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 Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _
(ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, _
ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
Private Sub cmdConnect_Click()
Dim lCount As Long, lctr As Long
Dim bAns As Boolean
Screen.MousePointer = vbHourglass
lCount = txtName.UBound
Set pDictValues = New Scripting.Dictionary
If Connect(txtServer.Text) Then
For lctr = 0 To lCount
If Trim(txtName(lctr).Text) <> "" And Trim(txtValue(lctr).Text) <> "" Then
pDictValues.Add txtName(lctr).Text, txtValue(lctr).Text
End If
Next
bAns = PostRequest(txtScript.Text)
If Not bAns Then
MsgBox "Failed to post response to html or script page", vbCritical, "Check Your Values"
End If
Else
MsgBox "Failed to connect to server", vbCritical, "Check Your Values"
End If
Disconnect
Screen.MousePointer = vbDefault
End Sub
Public Function PostRequest(ScriptName As String) As Boolean
Dim lRequest As Long
Dim sData As String
Dim sAns As String
Dim lRead As Long
Dim sResult As String
Dim lctr As Long
Dim sHeader As String
Dim lLen As Long
Dim sRequestType As String
Dim sUrl As String
If pDictValues.Count > 0 Then
sRequestType = IIf(optRequestType(0).Value = True, "POST", "GET")
If sRequestType = "GET" Then sData = "?"
'construct post or get request
For lctr = 0 To UBound(pDictValues.Keys)
sData = sData & pDictValues.Keys(lctr) & "=" & pDictValues.Items(lctr)
If lctr < UBound(pDictValues.Keys) Then sData = sData & "&"
Next
Else
'if no name/value pairs entered, it's a request for a page that
'does not take form values as parameters (e.g., static page)
End If
sUrl = ScriptName
If sRequestType = "GET" Then
sUrl = sUrl & sData
sData = ""
End If
'Open request
lRequest = HttpOpenRequest(plConnection, sRequestType, sUrl, "HTTP/1.1", "", 0, _
INTERNET_FLAG_KEEP_CONNECTION, 0)
If lRequest <> 0 Then
plRequest = lRequest
Else
Disconnect
End If
If sRequestType = "POST" Then
sHeader = "Content-Type: application/x-www-form-urlencoded"
lLen = Len(sHeader)
End If
'send request
If HttpSendRequest(plRequest, sHeader, lLen, sData, Len(sData)) > 0 Then
sAns = space$(RESPONSE_LENGTH)
Do While InternetReadFile(plRequest, sAns, RESPONSE_LENGTH, lRead)
If lRead = 0 Then
Exit Do
Else
sResult = sResult & Left$(sAns, lRead)
End If
lRead = 1024
sAns = space$(lRead)
Loop
'display results
frmResponse.txtResult.Text = HTML2Text(sResult)
Screen.MousePointer = vbDefault
frmResponse.Show vbModal
PostRequest = True
Else
Disconnect
End If
End Function
Public Sub Disconnect()
'Clean Up
On Error Resume Next
InternetCloseHandle plRequest
InternetCloseHandle plConnection
InternetCloseHandle plHandle
End Sub
附一个网址编码函数：
Private Function UrlEncode(sText As String) As String
'This function converts non-alphanumeric characters to their
'hexadecimal equivalents, as required by http protocol.
Dim sTemp As String
Dim sAns As String
Dim sChar As String
Dim lctr As Long
For lctr = 1 To Len(sText)
sChar = Mid$(sText, lctr, 1)
'is it alphanumeric
If sChar Like "[0-9A-Za-z]" Then
sTemp = sTemp & sChar
ElseIf sChar = " " Then
sTemp = sTemp & "+"
ElseIf True Then
sTemp = sTemp & "%" & Right$("0" & Hex(Asc(sChar)), 2)
End If
If Len(sTemp) > 1000 Then
sAns = sAns & sTemp
sTemp = ""
End If
Next
UrlEncode = sAns & sTemp
End Function
已经有(1)位网友发表了评论，你也评一评吧！
原创文章如转载，请注明：转载自Eddy Blog
原文地址：http://www.rrgod.com/program/545.html 欢迎订阅Eddy Blog。
Tags:VB post get request wininet.dll
又素代码，人家看的头晕啦。