QueryTabels Internet Timeout

Folgende Aufgabe:
Ich hole mir via unten stehender Webabfrage Daten aus dem Internet.
Nun kommt es hin und wieder mal vor, dass die Abfrage beim Refresh hängen bleibt und ich VBA mit ESC stoppen muss.
Gerne hätte ich einen Timer, der z.B. nach 5 Sekunden aus der Abfrage aussteigt und mir den Status der Abfrage (gut/schlecht) mitteilt.
Danke für die Unterstützung.
Grüße
Peter
With Activesheet.QueryTables.Add(Connection:= _
"URL;http://index.onvista.de", _
Destination:=Range("A1"))
.name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.webTables = "5,7"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
was Du möchtest ist nicht umzusetzen und irgendwie von MS auch nicht bedacht wurden.
Wahrscheinlich geht man bei MS davon aus, dass eine Webseite die man abfragen möchte immer erreichbar ist.
Eine alternative kann ich Dir nur in sofern anbieten (etwas besseres ist mir nicht eingefallen),
dass ich die Webseite zuvor aufrufe und prüfe ob diese vollständig geladen wird, diese Abfrage habe ich Zeitlich begrenzt (im Beispiel 15 Sekunden).
Vielleicht hilft Dir dies weiter, Kommentare stehen im Code.
Modul Modul1

Option Explicit 
 
Sub Test_Webabfrage() 
Dim appIE As Object 
Dim byZähler As Byte, WarteZeitInSekunden As Byte 
Dim strMeineURL As String 
 
'Zeit in Sekunden 
WarteZeitInSekunden = 15 
'Meine Webseite 
strMeineURL = "http://index.onvista.de" 
 
Set appIE = CreateObject("InternetExplorer.application") 
appIE.Visible = False 
appIE.Navigate strMeineURL 
 
'Prüfen ob Webseite vollständig geladen werden kann 
While Not appIE.ReadyState = 4 And byZähler < WarteZeitInSekunden 'Warte auf Webseite 
    Application.Wait Now + CDate("00:00:01") 
    byZähler = byZähler + 1 
    DoEvents 
Wend 
appIE.Quit 
Set appIE = Nothing 
 
    If byZähler >= WarteZeitInSekunden Then 
     'vollständiges laden der Webseite war erfolglos 
        MsgBox "Webseite" & Chr(13) & _
        strMeineURL & Chr(13) & _
        "ist nicht erreichbar!", vbCritical, "Fehler!" 
    Else 
     'vollständiges laden der Webseite war erfolgreich 
        With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & strMeineURL, _
        Destination:=Range("A1")) 
        .Name = "" 
        .FieldNames = True 
        .RowNumbers = False 
        .FillAdjacentFormulas = False 
        .PreserveFormatting = True 
        .RefreshOnFileOpen = False 
        .BackgroundQuery = True 
        .RefreshStyle = xlInsertDeleteCells 
        .SavePassword = False 
        .SaveData = True 
        .AdjustColumnWidth = True 
        .RefreshPeriod = 0 
        .WebSelectionType = xlSpecifiedTables 
        .WebFormatting = xlWebFormattingNone 
        .WebTables = "5,7" 
        .WebPreFormattedTextToColumns = True 
        .WebConsecutiveDelimitersAsOne = True 
        .WebSingleBlockTextImport = False 
        .WebDisableDateRecognition = False 
        .WebDisableRedirections = False 
        .Refresh BackgroundQuery:=False 
        End With 
    End If 
End Sub

Gruß Tino

www.VBA-Excel.de

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread