Hi. Ich hab mich nie näher mit der winsock-programmierung befasst. Aber hier ein Stück ausgetesteten Codes. Damit kann man eine beliebiges Http-Dokument aus dem Netz beziehen.
Vielleicht hilfts dir was.
Zur Bedienung: man ruft die Funktion geturl mit der url und einem „to do-string“ auf.
Da die Verbindung ja asynchron ist, ruft das Programm dann die Funktion „httpResponse“ auf. In dieser kann man dann anhand dem todo-string entscheiden, was man man mit der Antwort zu tun gedenkt.
cu, holli
' in die Form mit dem winsock-Steuerelement:
Private Sub ReadURL(url As String)
Call winsock.wsReadURL(url)
End Sub
Private Sub wscHttp\_Close()
Call winsock.wswscHttp\_Close
txtDownloadStatus = txtDownloadStatus & Chr(13) & Chr(10) & "Verbindung beendet..."
End Sub
Private Sub wscHttp\_Connect()
If txtDownloadStatus "" Then txtDownloadStatus = txtDownloadStatus & Chr(13) & Chr(10)
txtDownloadStatus = txtDownloadStatus & "Verbindungsaufbau..."
Call winsock.wswscHttp\_Connect
End Sub
Private Sub wscHttp\_DataArrival(ByVal bytesTotal As Long)
If txtDownloadStatus = "Verbindungsaufbau..." Then
txtDownloadStatus = txtDownloadStatus & Chr(13) & Chr(10) & "Empfange Daten..."
Else
txtDownloadStatus = txtDownloadStatus & "....."
End If
Call winsock.wswscHttp\_DataArrival(bytesTotal)
End Sub
Private Sub wscHttp\_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
txtDownloadStatus = txtDownloadStatus & Chr(13) & Chr(10) & "Fehler..."
Call winsock.wswscHttp\_Error(Number, Description, Scode, Source, HelpFile, HelpContext, CancelDisplay)
End Sub
Private Function GetHttpResponseCode(strHttpHeader) As Integer
GetHttpResponseCode = winsock.wsGetHttpResponseCode(strHttpHeader)
End Function
Private Function GetAuthenticationScheme(strHttpHeader As String) As String
GetAuthenticationScheme = winsock.wsGetAuthenticationScheme(strHttpHeader)
End Function
Private Function GetProxyAuthenticationScheme(strHttpHeader As String) As String
GetProxyAuthenticationScheme = winsock.wsGetProxyAuthenticationScheme(strHttpHeader)
End Function
Private Function Base64\_Encode(strSource) As String
Base64\_Encode = winsock.wsBase64\_Encode(strSource)
End Function
Private Function GetHttpHeaderFieldValue(strHttpHeader As String, strHttpHeaderField As String) As String
GetHttpHeaderFieldValue = winsock.wsGetHttpHeaderFieldValue(strHttpHeader, strHttpHeaderField)
End Function
Public Sub httpResponse(ByVal strHttpResponse As String, ByVal strContent\_Type\_Class As String, ByVal strContent\_Type\_Arg As String, ByVal httpToDo As String)
Select Case httpToDo
Case "dbupdate"
Call dbupdate.write\_dbUpdate(App.path & "\kunden.mdb", strHttpResponse)
End Select
End Sub
in ein .bas-modul:
Option Explicit
Public m\_ProxyPassword As String
Public m\_strRemoteHost As String 'the web server to connect to
Public m\_strFilePath As String 'relative path to the file to retrieve
Public m\_strHttpResponse As String 'the server response
Public m\_strhttpToDo As String
Public m\_strMainHttpResponse As String
Public m\_bMainDownload As Boolean
Public m\_bResponseReceived As Boolean 'flag variable
Public m\_bHeaderReceived As Boolean 'flag variable
Public m\_lContentLength As Long 'value of "Content-Length" HTTP header
Public m\_lDownloadedBytes As Long
Public m\_bDownloadInProgress As Boolean
'
Public Sub ws\_ReadURL(url As String, Optional ByVal httpToDo As String)
'
Dim strURL As String 'temporary buffer
Dim intPort As Integer
'
On Error GoTo ERROR\_HANDLER
'
m\_strhttpToDo = httpToDo
If Len(url) = 0 Then
MsgBox "Please, enter the URL to retrieve.", vbInformation
Exit Sub
End If
'
If m\_useProxy Then
'
'Using Proxy
'
If Len(m\_ProxyPort) \> 0 And Len(m\_ProxyServer) \> 0 Then
'
m\_strRemoteHost = m\_ProxyServer
intPort = CInt(m\_ProxyPort)
m\_strFilePath = url
'
If Not Left(m\_strFilePath, 7) = "http://" Then
m\_strFilePath = "http://" & m\_strFilePath
End If
'
End If
'
Else
'
'set default port number = 80
'
intPort = 80
'
'if the user has entered "http://", remove this substring
'
If Left(url, 7) = "http://" Then
strURL = Mid(url, 8)
Else
strURL = url
End If
'
'get remote host name
'
m\_strRemoteHost = Left$(strURL, InStr(1, strURL, "/") - 1)
'
'get relative path to the file to retrieve
'
m\_strFilePath = Mid$(strURL, InStr(1, strURL, "/"))
'
End If
'
'clear the buffer
'
m\_strHttpResponse = ""
'
'turn off the m\_bResponseReceived flag
'
m\_bResponseReceived = False
'
'reset values of the module level variables
'
m\_bHeaderReceived = False
m\_lContentLength = 0
m\_lDownloadedBytes = 0
'
'establish the connection
'
With frmSystem.wscHttp
.Close
.LocalPort = 0
.Connect m\_strRemoteHost, intPort
End With
'
EXIT\_LABEL:
Exit Sub
Resume Next
ERROR\_HANDLER:
'
If Err.Number = 5 Then
strURL = strURL & "/"
Resume 0
Else
MsgBox "Error was occurred." & vbCrLf & \_
"Error #: " & Err.Number & vbCrLf & \_
"Description: " & Err.Description, vbExclamation
GoTo EXIT\_LABEL
End If
'
End Sub
Public Sub ws\_wscHttp\_Close()
'
Dim strHttpResponseHeader As String
Dim strMessage As String
'
'to cut of the header info, we must find
'a blank line (vbCrLf & vbCrLf)
'that separates the message body from the header
'
If Not m\_bResponseReceived Then
strHttpResponseHeader = Left$(m\_strHttpResponse, \_
InStr(1, m\_strHttpResponse, \_
vbCrLf & vbCrLf) - 1)
'Debug.Print strHttpResponseHeader
m\_strHttpResponse = Mid(m\_strHttpResponse, \_
InStr(1, m\_strHttpResponse, \_
vbCrLf & vbCrLf) + 4)
If m\_bMainDownload Then m\_strMainHttpResponse = m\_strHttpResponse
'
Dim strContent\_Type, strContent\_Type\_Class As String, strContent\_Type\_Arg As String
strContent\_Type = ws\_GetHttpHeaderFieldValue(strHttpResponseHeader, "Content-Type")
strContent\_Type\_Class = Left(strContent\_Type, InStr(strContent\_Type, "/") - 1)
strContent\_Type\_Arg = Mid(strContent\_Type, InStr(strContent\_Type, "/") + 1)
frmSystem.wscHttp.Close
Call frmSystem.httpResponse(m\_strHttpResponse, strContent\_Type\_Class, strContent\_Type\_Arg, m\_strhttpToDo)
m\_bResponseReceived = True
End If
'
If ws\_GetHttpResponseCode(strHttpResponseHeader) = 401 Then
'
If ws\_GetAuthenticationScheme(strHttpResponseHeader) = "Basic" Then
'
strMessage = "You must provide user name and password to retrieve the resource by that URL."
'
Else
'
strMessage = "This resource requires a Digital Authentication Scheme for the user authorization." & vbCrLf & \_
"Sorry, this sample does support only for Basic Authentication Scheme."
'
End If
'
ElseIf ws\_GetHttpResponseCode(strHttpResponseHeader) = 407 Then
'
If ws\_GetProxyAuthenticationScheme(strHttpResponseHeader) = "Basic" Then
'
strMessage = "You must provide user name and password for the proxy authorization."
'
Else
'
strMessage = "The proxy server requires the user authorization using a Digital Authentication Scheme." & vbCrLf & \_
"Sorry, this sample does support only for Basic Authentication Scheme."
'
End If
End If
'
If Len(strMessage) \> 0 Then
MsgBox strMessage, vbExclamation, "Unauthorized Request"
End If
'
m\_bDownloadInProgress = False
End Sub
Public Sub ws\_wscHttp\_Connect()
'
Dim strHttpRequest As String
'
'create the HTTP Request
'
'build request line that contains the HTTP method,
'path to the file to retrieve,
'and HTTP version info. Each line of the request
'must be completed by the vbCrLf
strHttpRequest = "GET " & m\_strFilePath & " HTTP/1.1" & vbCrLf
'
'add HTTP headers to the request
'
'add required header - "Host", that contains the remote host name
'
strHttpRequest = strHttpRequest & "Host: " & m\_strRemoteHost & vbCrLf
'
'add the "Connection" header to force the server to close the connection
'
strHttpRequest = strHttpRequest & "Connection: close" & vbCrLf
'
'add optional header "Accept"
'
strHttpRequest = strHttpRequest & "Accept: \*/\*" & vbCrLf
'
If Len(m\_UserName) \> 0 And Len(m\_Password) \> 0 Then
strHttpRequest = strHttpRequest & "Authorization: Basic "
strHttpRequest = strHttpRequest & CStr(wsBase64\_Encode(m\_UserName & ":" & m\_Password)) & vbCrLf
End If
'
If Len(m\_ProxyUserName) \> 0 And Len(m\_ProxyPassword) \> 0 Then
strHttpRequest = strHttpRequest & "Proxy-Authorization: Basic "
strHttpRequest = strHttpRequest & ws\_Base64\_Encode(m\_ProxyUserName & ":" & \_
m\_ProxyPassword) & vbCrLf
End If
'
'add other optional headers
'
'strHttpRequest = strHttpRequest & & \_
& vbCrLf
'. . .
'
'add a blank line that indicates the end of the request
strHttpRequest = strHttpRequest & vbCrLf
'
'send the request
frmSystem.wscHttp.SendData strHttpRequest
'
'Debug.Print strHttpRequest
'
End Sub
Public Sub ws\_wscHttp\_DataArrival(ByVal bytesTotal As Long)
'
On Error Resume Next
'
Dim strData As String
Dim intBreakePosition As Integer
Dim vHeaders As Variant
Dim vHeader As Variant
'
'
'get arrived data from winsock buffer
'
frmSystem.wscHttp.GetData strData, vbString
'
'store the data in the m\_strHttpResponse variable
m\_strHttpResponse = m\_strHttpResponse & strData
'
m\_lDownloadedBytes = m\_lDownloadedBytes + bytesTotal
'
If Not m\_bHeaderReceived Then
intBreakePosition = InStr(1, m\_strHttpResponse, vbCrLf & vbCrLf)
If intBreakePosition Then
m\_bHeaderReceived = True
m\_lDownloadedBytes = m\_lDownloadedBytes - intBreakePosition - 3
vHeaders = Split(Left(m\_strHttpResponse, intBreakePosition - 1), vbCrLf)
For Each vHeader In vHeaders
If InStr(1, vHeader, "Content-Length") Then
m\_lContentLength = CLng(Mid(vHeader, InStr(1, vHeader, " ") + 1))
Exit For
End If
Next
End If
End If
'
End Sub
Public Sub ws\_wscHttp\_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Error was occurred." & vbCrLf & \_
"Error #: " & Number & vbCrLf & \_
Description, vbExclamation, "Error"
frmSystem.wscHttp.Close
End Sub
Public Function ws\_GetHttpResponseCode(strHttpHeader) As Integer
'
Dim varCode As Variant
'
varCode = Mid(strHttpHeader, InStr(1, strHttpHeader, " ") + 1, 3)
'
If IsNumeric(varCode) Then
'
ws\_GetHttpResponseCode = CInt(varCode)
'
End If
'
End Function
Public Function ws\_GetAuthenticationScheme(strHttpHeader As String) As String
'
Dim strBuffer As String
Dim intStart As Integer
Dim strSearchString As String
'
strSearchString = vbCrLf & "WWW-Authenticate: "
'
intStart = InStr(1, strHttpHeader, strSearchString) + \_
Len(strSearchString)
strBuffer = Mid$(strHttpHeader, intStart, InStr(intStart, strHttpHeader, " ") - intStart)
'
If Len(strBuffer) \> 0 Then
ws\_GetAuthenticationScheme = strBuffer
End If
'
End Function
Public Function ws\_GetProxyAuthenticationScheme(strHttpHeader As String) As String
'
Dim strBuffer As String
Dim intStart As Integer
Dim strSearchString As String
'
strSearchString = vbCrLf & "Proxy-Authenticate: "
'
intStart = InStr(1, strHttpHeader, strSearchString) + \_
Len(strSearchString) + 1
strBuffer = Mid$(strHttpHeader, intStart, InStr(intStart, strHttpHeader, " ") - intStart)
'
If Len(strBuffer) \> 0 Then
ws\_GetProxyAuthenticationScheme = strBuffer
End If
'
End Function
Public Function ws\_Base64\_Encode(strSource) As String
'
Const BASE64\_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
'
Dim strTempLine As String
Dim j As Integer
'
For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
'Breake each 3 (8-bits) bytes to 4 (6-bits) bytes
'
'1 byte
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
'2 byte
strTempLine = strTempLine + Mid(BASE64\_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) \* 16 \_
+ Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
'3 byte
strTempLine = strTempLine + Mid(BASE64\_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) \* 4 \_
+ Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
'4 byte
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
Next j
'
If Not (Len(strSource) Mod 3) = 0 Then
'
If (Len(strSource) Mod 3) = 2 Then
'
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
'
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) \* 16 \_
+ Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
'
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) \* 4 + 1, 1)
'
strTempLine = strTempLine & "="
'
ElseIf (Len(strSource) Mod 3) = 1 Then
'
'
strTempLine = strTempLine + Mid(BASE64\_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
'
strTempLine = strTempLine + Mid(BASE64\_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) \* 16 + 1, 1)
'
strTempLine = strTempLine & "=="
'
End If
'
End If
'
ws\_Base64\_Encode = strTempLine
'
End Function
Public Function ws\_GetHttpHeaderFieldValue(strHttpHeader As String, strHttpHeaderField As String) As String
'
Dim strBuffer As String
Dim intStart As Integer
Dim strSearchString As String
'
strSearchString = vbCrLf & strHttpHeaderField & ": "
'
' MsgBox strHttpHeader
intStart = InStr(1, strHttpHeader, strSearchString) + Len(strSearchString)
strBuffer = Mid$(strHttpHeader, intStart, Abs(InStr(intStart, strHttpHeader, vbCrLf) - intStart))
'
If Len(strBuffer) \> 0 Then
ws\_GetHttpHeaderFieldValue = strBuffer
End If
'
End Function
