Von webseiten daten auslesen ! WIE !

ich möchte von webseiten daten auslesen und diese über vb auswerfen.

da ich weder programmierer bin noch viel ahnung davon habe suche ich jemanden, der soetwas schon programmiert hat und mir eventuel weiterhelfen kann.

vielleicht gibt es schon programme die soetwas können !

wer kann helfen !

ich kann die daten aus webseiten auch auf excel ziehen, kann diese aber nicht aktualisieren .

ideen

danke !!!

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