Re: von webseiten daten auslesen !!! WIE !!!!!

Hi!
Hier ein voll funktionsfähiger Code. Du brauchts dazu nur ein WinSock-Control namens wscHttp auf deiner Form.
Dann fügst du in die Form den ersten Teil des untenstehenden Codes ein. In ein Basic Modul namens Winsock fügst du den zweiten Teil ein. Dann rufst du winsock.wsreadUrl folgendermaßen auf:
call winsock.wsReadUrl ("http://www.irgendwo.de","speichern",me)

Die Abfrage wird dann gestartet. Da es eine asynchrone Abfrage ist, läuft dein Programm erstmal weiter, während die Abfrage abläuft. Irgendwann sind einmal alle Daten zurückgekommen.

Dann wird in deiner aufrufenden Form die Funktion "httpResponse" aufgerufen in der du anhand des ToDo-Strings entscheiden kannst, was du mit den Daten machen willst.

Schau es dir mal an. Wenn du nicht klar kommst schick ich dir ein kleines Testprojekt.

grüße, Holli


Code in der Form
'
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 Long
    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)
    Dim s As String
    Select Case httpToDo
    Case "dbupdate"
        Call dbupdate.write_dbUpdate(App.path & "\data.mdb", strHttpResponse)
    Case "account"
        MsgBox "Ihr aktueller Kontostand beträgt: DM" & strHttpResponse
    End Select
End Sub
'
Code in Modul namens "winsock"
'
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 wsReadURL(ByVal URL As String, ByVal httpToDo As String, calling_form As Object)
    '
    Dim strURL As String    'temporary buffer
    Dim intPort As Long
    '
    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 calling_form.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 wswscHttp_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 = wsGetHttpHeaderFieldValue(strHttpResponseHeader, "Content-Type")
strContent_Type_Class = Left(strContent_Type, InStr(strContent_Type, "/") - 1)
strContent_Type_Arg = Mid(strContent_Type, InStr(strContent_Type, "/") + 1)

calling_form.wscHttp.Close
Call calling_form.httpResponse(m_strHttpResponse, strContent_Type_Class, strContent_Type_Arg, m_strhttpToDo)

m_bResponseReceived = True

End If
'
If wsGetHttpResponseCode(strHttpResponseHeader) = 401 Then
'
If wsGetAuthenticationScheme(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 wsGetHttpResponseCode(strHttpResponseHeader) = 407 Then
'
If wsGetProxyAuthenticationScheme(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 wswscHttp_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 & wsBase64_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
calling_form.wscHttp.SendData strHttpRequest
'
'Debug.Print strHttpRequest
'
End Sub

Public Sub wswscHttp_DataArrival(ByVal bytesTotal As Long)
'
On Error Resume Next
'
Dim strData As String
Dim intBreakePosition As Long
Dim vHeaders As Variant
Dim vHeader As Variant
'

'
'get arrived data from winsock buffer
'
calling_form.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 wswscHttp_Error(ByVal Number As Long, 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"
calling_form.wscHttp.Close

End Sub

Public Function wsGetHttpResponseCode(strHttpHeader) As Long
'
Dim varCode As Variant
'
varCode = Mid(strHttpHeader, InStr(1, strHttpHeader, " ") + 1, 3)
'
If IsNumeric(varCode) Then
'
wsGetHttpResponseCode = CInt(varCode)
'
End If
'
End Function

Public Function wsGetAuthenticationScheme(strHttpHeader As String) As String
'
Dim strBuffer As String
Dim intStart As Long
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
wsGetAuthenticationScheme = strBuffer
End If
'
End Function

Public Function wsGetProxyAuthenticationScheme(strHttpHeader As String) As String
'
Dim strBuffer As String
Dim intStart As Long
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
wsGetProxyAuthenticationScheme = strBuffer
End If
'
End Function

Public Function wsBase64_Encode(strSource) As String
'
Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
'
Dim strTempLine As String
Dim j As Long
'
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
'
wsBase64_Encode = strTempLine
'
End Function

Public Function wsGetHttpHeaderFieldValue(strHttpHeader As String, strHttpHeaderField As String) As String
'
Dim strBuffer As String
Dim intStart As Long
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
wsGetHttpHeaderFieldValue = strBuffer
End If
'
End Function