12.11.2014

10865

Excel 2010 VB Makro Inhalt einer Webseite in Browser kopieren schlägt fehlt

Hallo liebe Leute!

ich möchte den Inhalt einer Webseite in ein Excel Sheet kopieren.

manueller Weg: Seite öffnen>Str+A>Str+C>Excel>Str+V
also nicht den Code kopieren und einfügen (!)

Hier mein aktueller code:

Private Sub CopyHtmlToClipboard(wwwAdress As String)
     Dim appIE As Object
     Set appIE = CreateObject("InternetExplorer.Application")  

     appIE.navigate wwwAdress
     appIE.Visible = False

     Do: Loop Until appIE.Busy = False
     appIE.ExecWB 17, 0 'Select All  

     Do: Loop Until appIE.Busy = False
     appIE.ExecWB 12, 0 'Copy  

     Do: Loop Until appIE.Busy = False

     appIE.Application.Quit
     Set appIE = Nothing
End Sub

Grundsätzlich funktioniert das auch. Nur nicht bei der gewünschten (internen!) Seite.
ich vermute folgdendes als Ursache:

Diese erfordert eine Browser Authentifizierung.
Sprich der Broser überträgt die Nutzerdaten authomatisch.
Wie so üblich bei ERP Systemen..

Bei der Seite handelt es sich um eine .aspx Seite,
falls dass eine Rolle spielt.

Gruß aus dem noch nebeligen Bayern
SweetOne

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 254556

Url: https://administrator.de/forum/excel-2010-vb-makro-inhalt-einer-webseite-in-browser-kopieren-schlaegt-fehlt-254556.html

Ausgedruckt am: 31.12.2024 um 20:12 Uhr

17 Kommentare

Neuester Kommentar

Hallo SweetOne!

Hast Du es auch mal per Daten>Externe Webabfrage versucht?

Teste mal damit:

Sub TestUrl(ByRef sUrl)
    Dim sText As String
    
    On Error Resume Next
    With CreateObject("WinHttp.WinHttpRequest.5.1")  
        .Open "Get", sUrl, False  
        .Send
         sText = .ResponseText
    End With
    On Error GoTo 0
    
    If sText <> "" Then  
        MsgBox True
    Else
        MsgBox False
    End If
End Sub

Wahr oder Falsch?

Wenn Wahr, kompletten Inhalt (body) oder nur Tabellen (table)?

Grüße Dieter

Hallo Eintragsfliege,

ich hatte es noch nicht mit der externen Webabfrage Versucht.
Sehr nette idee .. leider kopiert er nur die Tabllen, nicht den Inhalt.
Ich fürchte das Excel hier nicht geduldig genug ist,
da Sie Seiten eine gewisse Ladezeit haben.

Als Makro stellt sich das so dar (google als Beispiel)

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://www.google.de/?gws_rd=ssl", Destination:=Range("$A$1"))  
        .Name = "?gws_rd=ssl"  
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

Kann man hier vlt. ihrgendwie eine Warezeit einstellen?

Das Ergebnis der Abfrage ist jedenfalls wahr.
Der hover beim Debugger zeigt das der body usw eingeladen wird.
..

Kann ich den html code vlt auch in den Browser wieder rein laden und dann versuchen zu kopieren?

Gruß der Dämmerung
SweetOne

PS: hatte heute leider nicht viel zeit mir die neuen Infos viel näher anzusehen, morgen hoffe ich =)

Hallo SweetOne!

Und wie funktioniert es hiermit:

Public Sub Test()
   'Body=xlEntirePage, AllTables=xlAllTables  
    Call GetWebDaten("https://www.google.de/?gws_rd=ssl", xlEntirePage)  
   'Call GetWebDaten("https://www.google.de/?gws_rd=ssl", xlAllTables)   
End Sub

Private Sub GetWebDaten(ByRef sUrl, ByVal iMode As Long)
    Dim sHtmlText As String, sHtmlFile As String, sHtmlQuery As String
    Dim sText As String, i As Integer
    
    On Error Resume Next
    With CreateObject("WinHttp.WinHttpRequest.5.1")  
        For i = 1 To 3  'Max 3 Versuche  
           .Open "Get", sUrl, False  
           .Send
            sText = .ResponseText
            If sText <> "" Then  
                Exit For
            End If
        Next
    End With
    On Error GoTo 0
    
    If sText <> "" Then  
        sHtmlText = "<html><head><title></title></head><body>"  
        sHtmlText = sHtmlText & Split(sText, "<body")(1)  
        sHtmlFile = Environ("Temp") & "\Temp.html"  
        sHtmlQuery = "FINDER;File:///" & Replace(sHtmlFile, "\", "/")  
                    
        With CreateObject("Scripting.FileSystemObject")  
            .CreateTextFile(sHtmlFile).Write sHtmlText
             Do Until .FileExists(sHtmlFile): Loop
        End With
    
        With ActiveSheet
           .UsedRange.Cells.Clear
            With .QueryTables.Add(Connection:=sHtmlQuery, Destination:=.Range("A1"))  
                .AdjustColumnWidth = True
                .WebSelectionType = iMode    'xlAllTables, xlEntirePage  
                .WebFormatting = xlWebFormattingNone
                .Refresh BackgroundQuery:=False
                .Delete
            End With
        End With
    End If
End Sub

Grüße Dieter

Hallo Dieter,

sehr schöner Ansatz den ich selbst sicherlich nicht geschafft hätte.
Zumindest nicht so schnell. Bei google Funktioniert der Ansatz auch...

Aber bei der problematischen ERP Seite leider nicht... =(

Mich irritiert das die Daten aus dem Web Abfrage scheinbar keine Zugriffsprobleme hat...
dafür sind aber auch die Tabellen leer.

Serverfehler
401 - Nicht autorisiert: Zugriff aufgrund ungültiger Anmeldeinformationen verweigert.
Die angegebenen Anmeldeinformationen berechtigen Sie nicht, dieses Verzeichnis oder >diese Seite anzuzeigen.

Noch eine Idee dazu?
So langsam glaube ich, dass es einfach nicht geht.... .

Wäre sehr schade, es geht um eine monatliche Kopierarbeit im Umfang von etwa 25 Seiten und Excel Erstellung,
welche sehr schön für ein Makro wäre. Wenn es funktioniert sicherlich auch mehr als einmal im Monat..

Ergänzung: Sehr gute Seite gefunden wo ich glaube ich mit weiter komme.
http://www.freecoffee.de/2014/09/tutorial-web-scraping-mit-vba-teil-1/

Sehr lange gesucht aber erst jetzt nach der Recherche nach der HTTP request gefunden.

Darin verwendet wird URLencode...:
http://dc-storm.com/de/news-events/news/urlencode-urldecode-als-excel-f ...
Funktioniert bei mir nur leider nicht.
Alternative: http://www.dorf-rauxel.de/picard/tools/urlcode.php

Mit freundlichen Grüßen
SweetOne

Hallo,

also den Authentifizierungsfehler habe ich web bekommen.
ich habe den Befehl ".SetCredentials" ergänzt.

Nur sieht das resultat nun genau so aus wie beim Import über die Excel "Daten von Webseite" Funktion. Die Tabellen sind leer.

Die gleiche Adresse im Browser ist definitv nicht leer.

Ich habe nach meinem besten wissen Versucht über die msdn Seite weiter zu kommen:
http://msdn.microsoft.com/en-us/library/windows/desktop/aa384106(v=vs.8 ...

Leider komme ich auf keinen grünen Zweig =(.

Gruß
SweetOne

Hallo SweetOne!

Sorry, da ich keine Möglichkeit habe den Vorgang nachzustellen, kann ich Dir leider nicht weiterhelfen

Eventuell hätte Uwe (colinardo) als Allround-Experte diesbezüglich mehr Möglichkeiten und könnte weiterhelfen?

Versuchs mal mit einer PN an colinardo

Deine geposteten Links sind auch für mich sehr hilfreich, von daher mal Danke dafür...

Grüße Dieter

Hallo Dieter,

naja trotzdem danke! =)

weist du vlt ob die HTTP Request Funktion wartet bis die Seite geladen hat?

Gruß aus gefühlten Unterwelt in Bayern (Nebel)
SweetOne

Hallo SweetOne!

Yepp, HttpRequest wartet. Du kannst auch noch nach dem '.Send' eine Statusabfrage (MsgBox .Status) in den HttpRequest einbauen, wobei der Wert '200' für 'OK' steht...

Grüße Dieter

Hallo,

bin jetzt in der Ursachen Forschung weiter gekommen.

Ich habe die Seite im Browser gespeichert als html.
Hier war die Formatirung auf einmal total Wüst aber mit Inhalt.

Gepspeichert als .mht führte dazu das der IE eine Meldung bringt:

"Die Seite greift auf Informationen aus anderen Daten zu. (...) Möchten Sie fortsetzen.

Darauf hin öffnet sich ein neues Fenster und .... (!)
==> die Tabelle bleibt leer.

Soll heisen scheinbar existiert eine Art Ajax Stream welcher Seiten nachläd und im Lokalen Zustand den Server nicht erreicht.
Aufgrund des Seiten Umfangs habe ich das nicht gesehen.... .

Gruß aus Bayern
SweetOne

OK, dann versuchs mal damit:

Option Explicit
Option Compare Text

Private Const IE_READYSTATE_COMPLETE = 4

Public Sub Test()
   'Body=xlEntirePage, AllTables=xlAllTables  
    Call GetWebDaten("https://www.google.de/?gws_rd=ssl", xlEntirePage)  
End Sub

Private Sub GetWebDaten(ByRef sUrl, ByVal iMode As Long)
    Dim sHtmlText As String, sHtmlFile As String, sHtmlQuery As String, sText As String
    
     With CreateObject("InternetExplorer.Application")  
         .Navigate sUrl
          Do Until .ReadyState = IE_READYSTATE_COMPLETE:  Loop
          'Call WaitOfLoad(2)   'Falls Seite noch nicht geladen Wartezeit aktivieren  
          sText = .document.body.innerHtml
         .Quit
     End With
    
    If sText <> "" Then  
        sHtmlText = "<html><head><title></title></head><body>" & sText & "</body></html>"  
        sHtmlFile = Environ("Temp") & "\Temp.html"  
        sHtmlQuery = "FINDER;File:///" & Replace(sHtmlFile, "\", "/")  
                    
        With CreateObject("Scripting.FileSystemObject")  
            .CreateTextFile(sHtmlFile).Write sHtmlText
             Do Until .FileExists(sHtmlFile): Loop
        End With
    
        With ActiveSheet
           .UsedRange.Cells.Clear
            With .QueryTables.Add(Connection:=sHtmlQuery, Destination:=.Range("A1"))  
                .AdjustColumnWidth = True
                .WebSelectionType = iMode    'xlAllTables, xlEntirePage  
                .WebFormatting = xlWebFormattingNone
                .Refresh BackgroundQuery:=False
                .Delete
            End With
        End With
    End If
End Sub

'Funktion Warten auf Ausführung in Sekunden ( 1s = 1, 100ms = 0.1, 500ms = 0.5, 10ms = 0.01...)  
Private Sub WaitOfLoad(ByVal Sekunden As Double)
    Dim StopTime As Double
    StopTime = Date + ((Timer + Sekunden) / 86400)
    Do While StopTime >= (Date + Timer / 86400)
        DoEvents
    Loop
End Sub

Wobei Du bei Bedarf die Codezeile 17 mit einer Wartezeit versehen kannst...

Grüße aus (dem trüben) Baden-Württemberg
Dieter

Hallo,

ja zwei dumme ein Gedanke =). Genau das hatte ich auch versucht.
Bleibe aber bei deinem Script an der gleichen Stelle hängen wie an meiner.

Abgesehen davon ist deins ihrgendwie eleganter...
sText = .document.body.innerHTML

Die Methode 'Document' für das Objekt 'IWebBrowser 2' ist fehlgeschlagen

Mir fehlt aktuell noch der Wink woran das liegt....
Sind diese Bezeichnungen vom Dom aufbau der Seite abhängig?
Oder aber von der Browser Version. Bei mir IE8.

Gruß aus Bayern
SweetOne

Ergänzung:
Es ist nicht so das es grundsätzlich nicht geht. Google zum Beispiel geht wieder.
Der Aufbau zwischen der google seite und meiner erp seite ähneln sich. Denke nicht, dass das relevant ist.
Browser Version fällt weg da google funktioniert.

Vmtl Authentifizierung/Ajax

Hallo,

Ihrgendwie schlägt so gut wie jede Methode fehl mit der geöffneteten Internetexplorer Anwendung was zu machen.
(gilt nicht für google!!)

Ich habe es nun auch mal per ExecWB versucht... nicht gefunden.

appIE.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DONTPROMPTUSER, "c:\temp\test.pdf"

Aber eben nur speziell bei den Seiten.
Der Browser mit korrekten Inhalt geht ja auf.

---
werde heute wohl erstmal was anderes machen
das ist ja frustrierent =(

gruß
SweetOne

Hallo SweetOne!

Normalerweise kann bei Https-Seiten im Browser nicht auf den Documentinhalt zugegriffen werden oder der Quelltext angezeigt werden, was dann aber per Http-Request wiederum geht. Wenn die Tabellinhalte allerdings nach dem Öffnen der Website erst nachträglich mit einer Verzögerung geladen werden, sehe ich da keine Chance die Inhalte auszulesen.

Ändert sich nach dem Laden der Daten in der Address-Leiste irgendwas?

Grüße Dieter

Hallo Dieter,

keine direkte Verzögerung. Die Daten werden aus der SQL Datenbank ausgelesen und dann eingeladen. Wie gesagt so eine Art Ajax oder so. Die Adressleiste bleibt gleich.

Unter diesen Umständen muss ich wohl doch direkt die SQL Datenbank befragen.
Excel selbst schafft es nicht die SQL Abfrage durchzuführen. Ich denke mal zu komplex in diesem Fall, habe ich öfters.
Zudem brauch ich da sicherlich wieder einiges an Makro Code zum formatieren...
..ich hoffe das dies dann über VB ihrgendwie trotzdem zu händeln ist.
Zumal es eh etwas Tricky ist die Datenverbindung vom Excel per VB anzusteuern.

Aber das ist dann doch etwas out-of-topic würde ich mal sagen.

Gruß nach BaWü
SweetOne

Hallo SweetOne!

Unter diesen Umständen muss ich wohl doch direkt die SQL Datenbank befragen.
Excel selbst schafft es nicht die SQL Abfrage durchzuführen.

Das war auch mein erster Gedanke, wollte Dich damit aber nicht überfordern

Hast Du Zugriff (Rechte, Username, Passwort...) auf die Datenbank und kennst Tabellenname, Feldnamen...?

Grüße Dieter

Hallo Dieter,

Für die Abfrage habe ich einen speziellen Account mit Leserechten damit nichts verändert wird.
Den Connection String habe ich 1:1 aus der ODDB Verbindung kopiert.
Sollte dann passen oder?

Tabellen sind mir soweit vollständig bekannt und eine entsprechende Abfrage liegt schon bereit,
aus dem ERP genommen und im MS SQL Manager getestet.

In diesem VB-Bereich fehlt mir nur etwas die Erfahrung.
Ich bekomme einen Fehler nach dem anderen....

Sub test()
    'erforderliche Bilbiotek: Microsoft ActiveX Data Object 6.1 Library  
    
    'Deklaration von Variablen (wer hätte das gedacht  )  
    Dim con As ADODB.Connection 'Deklarieren der connection  
    Set con = New ADODB.Connection 'Instanzierung des Objektes  
    Dim RS As Recordset 'Deklaration des Recordset  
    Set RS = New ADODB.Recordset 'Instanzierung des Recordsets  
    Dim SQL As String
    SQL = "SELECT TOP 100 * from adressen"  
    
    'Öffnen der ODBC Schnittstelle DSN ist der DataSourceName  
    con.ConnectionString = "Provider=SQLOLEDB.1;Password=MeinPW;Persist Security Info=True;User ID=MeinUser;Initial Catalog=ERB_DB_NAME;Data Source=ERB_DB_SERVER;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=PCNAME;Use Encryption for Data=False;Tag with column collation when possible=False"  
    con.Open
    RS.Open SQL, con
    con.Close

End Sub

..Automatisierungsfehler ihrgendwas....
Ich habe google danach bemüht, leider erfolglos.

Der Fehler kommt in der Zeile RS.Open SQL, con.

Meine erste Ídee währe ein Fehlerhafter Connection String.
Auf der anderen Seite funktioniert dieser doch 1:1 in Excel.
Zudem sieht er nicht ganz falsch aus:
http://support.microsoft.com/kb/193135/de

Nachträgliche Anmerkung:
Wenn ich die ConnectionString verfäsche, sprich z.b. passwort ändere kommt direkt fehler,
hier scheint also alles i.O. zu sein. Verbindung scheint laut MS auch so zu stimmen:
http://technet.microsoft.com/en-us/library/aa905872(v=SQL.80).aspx

Anmerkung:
Connection String um Zugansdaten etc. abgeändert und SQL Select ganz einfach zum testen.

Gruß aus Bayern
SweetOne

Hallo SweetOne!

Zum Testen:

SQL = "SELECT * From adressen"

Connection-Beispiele sind hier noch zu finden...

Das Ganze dann in etwa so:

Public Sub GetData()
    Call DataImport("Tabelle1", "SELECT * From [Adressen]")  
End Sub

Private Sub DataImport(ByRef sSheetName, ByRef sSQL)
   'Verweis-Bibliothek: Microsoft ActiveX Data Object 6.1 Library  
    Dim con As ADODB.Connection, rs As Recordset
    Dim Wks As Worksheet, RowNext As Long, i As Long

    Set con = New ADODB.Connection 'Instanzierung des Objektes  
    Set rs = New ADODB.Recordset 'Instanzierung des Recordsets  

    'Öffnen der ODBC Schnittstelle DSN ist der DataSourceName  
    con.ConnectionString = "Connect-Daten"  
    con.Open
    
    'Dieser Teil schreibt die Daten (Spaltenüberschrift, Werte) in die Tabelle  
    If con.State = adStateOpen Then
        rs.Open sSQL, con
        
        Set Wks = Sheets(sSheetName):  Wks.UsedRange.ClearContents
        
        RowNext = 1
        
        With rs
            If .Fields.Count Then   'Import Spaltenüberschriften (Feldnamen)  
                For i = 0 To .Fields.Count - 1
                    Wks.Cells(RowNext, i + 1).Value = .Fields(i).Name
                Next
            End If
            
            Do Until .EOF   'Import Werte  
                RowNext = RowNext + 1
                For i = 0 To .Fields.Count - 1
                    Wks.Cells(RowNext, i + 1).Value = .Fields(i).Value
                Next
               .MoveNext
            Loop
           .Close
        End With
        con.Close
    Else
        MsgBox "Keine Verbindung!"  
    End If
End Sub

Grüße Dieter