以下工作需要 LibCurl:http ://curl.haxx.se/gknw.net/7.29.0/dist-w32/curl-7.29.0-devel-mingw32.zip
以及 libCurl 的 vb6 绑定:http: //sourceforge.net/projects/libcurl-vb/
主功能:
Public Sub Login()
Dim buf As New StringBuffer
CurlContext = vbcurl_easy_init()
vbcurl_easy_setopt CurlContext, CURLOPT_URL, "https://www.website.com/login-verify-user.wml"
vbcurl_easy_setopt CurlContext, CURLOPT_COOKIEJAR, App.Path & "\cookie.txt"
vbcurl_easy_setopt CurlContext, CURLOPT_COOKIEFILE, App.Path & "\cookie.txt"
vbcurl_easy_setopt CurlContext, CURLOPT_FOLLOWLOCATION, 1
vbcurl_easy_setopt CurlContext, CURLOPT_POST, 1
vbcurl_easy_setopt CurlContext, CURLOPT_POSTFIELDS, "UserName=" & URLencode(uID) & "&Password=" & URLencode(PWD) & "&Login=Login&Login="
'This section sets proxy settings, etc. and so is optional.
vbcurl_easy_setopt CurlContext, CURLOPT_TIMEOUT, 15
vbcurl_easy_setopt CurlContext, CURLOPT_PROXYAUTH, CURLAUTH_ANY
vbcurl_easy_setopt CurlContext, CURLOPT_HTTPPROXYTUNNEL, 1
vbcurl_easy_setopt CurlContext, CURLOPT_PROXY, proxyServer
vbcurl_easy_setopt CurlContext, CURLOPT_PROXYPORT, 80
vbcurl_easy_setopt CurlContext, CURLOPT_PROXYUSERPWD, ""
vbcurl_easy_setopt CurlContext, CURLOPT_CAINFO, CertFile
vbcurl_easy_setopt CurlContext, CURLOPT_SSLCERT, CertFile
vbcurl_easy_setopt CurlContext, CURLOPT_WRITEDATA, ObjPtr(buf)
vbcurl_easy_setopt CurlContext, CURLOPT_WRITEFUNCTION, _
AddressOf WriteFunction
vbcurl_easy_setopt CurlContext, CURLOPT_PROGRESSFUNCTION, _
AddressOf ProgressCallback
vbcurl_easy_setopt CurlContext, CURLOPT_NOPROGRESS, 0
vbcurl_easy_setopt CurlContext, CURLOPT_DEBUGFUNCTION, _
AddressOf DebugFunction
vbcurl_easy_setopt CurlContext, CURLOPT_VERBOSE, True
ret = vbcurl_easy_perform(CurlContext)
End Sub
放置在 .bas 文件中:
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function URLencode(ByRef TEXT As String) As String
Const Hex = "0123456789ABCDEF"
Dim lngA As Long, lngChar As Long
URLencode = TEXT
For lngA = LenB(URLencode) - 1 To 1 Step -2
lngChar = Asc(MidB$(URLencode, lngA, 2))
Select Case lngChar
Case 48 To 57, 65 To 90, 97 To 122
Case 32
MidB$(URLencode, lngA, 2) = "+"
Case Else
URLencode = LeftB$(URLencode, lngA - 1) & "%" & Mid$(Hex, (lngChar And &HF0) \ &H10 + 1, 1) & Mid$(Hex, (lngChar And &HF&) + 1, 1) & MidB$(URLencode, lngA + 2)
End Select
Next lngA
End Function
Public Function ProgressCallback(ByVal notUsed As Long, _
ByVal totaltodownload As Double, ByVal nowdownloaded As Double, _
ByVal totaltoupload As Double, ByVal nowuploaded As Double) As Long
'Paint and move form to avoid lock up
DoEvents
ProgressCallback = 0
End Function
' This function illustrates a couple of key concepts in libcurl.vb.
' First, the data passed in rawBytes is an actual memory address
' from libcurl. Hence, the data is read using the MemByte() function
' found in the VBVM6Lib.tlb type library. Second, the extra parameter
' is passed as a raw long (via ObjPtr(buf)) in Sub EasyGet()), and
' we use the AsObject() function in VBVM6Lib.tlb to get back at it.
Public Function WriteFunction(ByVal rawBytes As Long, _
ByVal sz As Long, ByVal nmemb As Long, _
ByVal extra As Long) As Long
Dim totalBytes As Long, i As Long
Dim obj As Object, buf As StringBuffer
Dim tempStr As String
Dim Buffer() As Byte
totalBytes = sz * nmemb
Set obj = AsObject(extra)
Set buf = obj
If Not ((rawBytes = 0) Or (totalBytes = 0)) Then
ReDim Buffer(0 To (totalBytes - 1)) As Byte
CopyMemory Buffer(0), ByVal rawBytes, totalBytes
tempStr = String(totalBytes, " ")
CopyMemory ByVal tempStr, Buffer(0), totalBytes
buf.quickConcat (tempStr)
End If
'Debug.Print buf.stringData
' Need this line below since AsObject gets a stolen reference
ObjectPtr(obj) = 0&
' Return value
WriteFunction = totalBytes
End Function
' Again, rawBytes comes straight from libcurl and extra is a
' long, though we're not using it here.
Public Function DebugFunction(ByVal info As curl_infotype, _
ByVal rawBytes As Long, ByVal numBytes As Long, _
ByVal extra As Long) As Long
Dim debugMsg As String
Dim i As Long
debugMsg = ""
For i = 0 To numBytes - 1
debugMsg = debugMsg & Chr(MemByte(rawBytes + i))
Next
Debug.Print "info=" & info & ", debugMsg=" & debugMsg
DebugFunction = 0
End Function
放在 StringBuffer.cls 中:
Private byteData() As Byte
Private stringLength As Long
Private arrayLength As Long
Private Sub Class_Initialize()
ReDim byteData(1024)
arrayLength = 1024
stringLength = 0
End Sub
Public Property Get stringData() As String
stringData = String(stringLength, " ")
CopyMemory ByVal stringData, byteData(0), stringLength
End Property
Public Property Let stringData(newStringdata As String)
Dim newStringLength As Long
newStringLength = Len(newStringdata)
If newStringLength > arrayLength Then
arrayLength = (arrayLength + (newStringLength - newStringLength Mod 2)) * 2
ReDim Preserve byteData(arrayLength)
End If
CopyMemory byteData(0), ByVal newStringdata, newStringLength
stringLength = newStringLength
End Property
Public Function quickConcat(newStringdata As String)
Dim newStringLength As Long
newStringLength = Len(newStringdata) + stringLength
If newStringLength > arrayLength Then
arrayLength = (arrayLength + (newStringLength - newStringLength Mod 2)) * 2
ReDim Preserve byteData(arrayLength)
End If
Dim amountToAdd
amountToAdd = newStringLength - stringLength
CopyMemory byteData(stringLength), ByVal newStringdata, amountToAdd
stringLength = newStringLength
End Function