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 _
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