Email über URL auslesen

[stepcke]

Hallo Zusammen,
kurz vorab: Ich habe früher (10 Jahre) als Anfänger viel mit VBA gemacht. In der Zwischenzeit weniger. Daher eingerostet.

Ich habe folgende Herausforderung:
In den Zellen A1:A2000, stehen eine URL (Websites)
Ich möchte nun alle Emails (mailto) finden und in die Zellen B1 ff schreiben.

Geht dies überhaupt? Kann im Netz nicht wirklich etwas finden.

Danke für euren Input

Stefan

[mumpel]

Hallo!

Das geht mit "Ersetzen".

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B
1	mailto:beispiel@beispiel.org	beispiel@beispiel.org

Zelle	Formel
B1	=ERSETZEN(A1;1;7;"")

Gruß, René

[stepcke]

Danke für deine Antwort.

Ich habe es vermutlich nicht richtig erklärt:
In der Zelle A1:A2000 stehen jeweils URL = http//www.xxxxx.de.

Soweit ich noch weiß kkann man irgendwie den Quellcode in die Zwischenablage lesen und dann nach Email Adressen durchsuchen.  hierfür nutzt man dann "mailto" für die Suche und nicht etwa das "@"-Zeichen.

Ich kann dies nur nicht mehr in VBA übersetzen. Ist zu lange her... :

[Case]

Hallo,

z. B. so:

Code:

Option Explicit
Public Sub Main()
    Dim objHTTPRequest As Object
    Dim strResult As String
    Dim strText As String
    Dim lngRow As Long
    On Error GoTo Fin
    Set objHTTPRequest = CreateObject("WinHTTP.WinHTTPrequest.5.1")
    objHTTPRequest.SetTimeouts 3000, 3000, 3000, 3000
    With ThisWorkbook.Worksheets("Tabelle1")
        For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
            objHTTPRequest.Open "GET", .Cells(lngRow, 1).Text, False
            objHTTPRequest.Send
            If objHTTPRequest.Status = 200 Then
                strText = objHTTPRequest.ResponseText
                strResult = fncMail(strText)
                If Trim$(strResult) = "" Then
                    strResult = "Keine Mailadresse!"
                Else
                    .Cells(lngRow, 2).Value = strResult
                End If
            Else
                strResult = "Keine Antwort!"
            End If
        Next lngRow
    End With
Fin:
    Set objHTTPRequest = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub
Private Function fncMail(ByVal strAll As String) As String
    Dim objRegEXP As Object
    Dim objMs As Object
    Dim objM As Object
    Dim strEmailAddress As String
    Set objRegEXP = CreateObject("VBScript.RegExp")
    With objRegEXP
        .Pattern = "([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})"
        .IgnoreCase = True
        .Global = True
        Set objMs = .Execute(strAll)
        If objMs.Count > 0 Then
            fncMail = objMs.Item(0).Value
        End If
    End With
    Set objM = Nothing
    Set objMs = Nothing
End Function

[stepcke]

Super, Danke.
Werde ich Morgen direkt ausprobieren!

[stepcke]

Hallo,

der Code funktioniert bedingt!

> Homepages von bestimmten Anbietern (z.B. Wix.com) werden nicht "richtig" ausgelesen.
   Hier taucht immer eine Platzhalter Email auf: "14370afcdc17429f9e418d5ffbd0334a@sentry.wixpress.com"
   Im Impressum steht aber eine echte: info@musterfirma.de

> Bei anderen Hompages wird gar nichts gefunden 
    Im Impressum steht aber eine echte: info@musterfirma.de

> Diverse Fehlermeldungen zwingen zum Neustart
[
Bild bitte so als Datei hochladen: Klick mich!
]

[color=#333333][size=small][font=Tahoma, Verdana, Arial, sans-serif]Für ca. 50 % konnte ich eine Email per VBA finden.

Dies ist schon eine riesige Erleichterung.

Danke dafür.

Vielleicht gibt es ja noch weitere Optimierungsmöglichkeiten. zum Beispiel ALLE Emails einer URL finden!

Danke

[Case]

Hallo,

nun - das ist klar. Je nachdem, wie die Seite aufgebaut ist, musst du entsprechend reagieren. Jetzt kommt die Fleißarbeit.

Etwas bequemer hast du es mit PowerShell. Da bläkt allerdings gerne der Virenscanner.

Nehmen wir mal dein Beispiel "Wix.com".

Mit...

Code:

varArr = Split(CreateObject("wscript.shell").exec("PowerShell (iwr ""https://de.wix.com"").links.href").stdout.readall, vbCrLf)

... erhältst du ein Array mit allen Links der Seite. Unter Anderem auch "https://de.wix.com/impressum"

Mit...

Code:

varArr = Split(CreateObject("wscript.shell").exec("PowerShell (iwr ""https://de.wix.com/impressum"").links.href").stdout.readall, vbCrLf)

... dann auch "mailto:support@wix.com".

Jetzt noch eine Schleife um deine Seiten und fertig.

Das lässt sich, mit Anpassungen, auch mit dem "WinHTTPrequest" machen.

[stepcke]

Hallo Case,

Danke für deine Antwort.
Ich habe mich mal wieder missverständlich ausgedrückt!

Das Beispiel bezog sich auf Service-Anbieter Wixpress mit dem einige Ihre Webseiten aufbauen. Hier findet der Code immer nur den  Platzhalter des Anbieters.

Ich kann mir vorstellen, dass deine Lösung bei meinen restlichen Adressen funktioniert. Denn hier wird auch kein Ergebnis ausgegeben. (siehe PN)

Nur habe ich keine Ahnung wo ich deinen Vorschlag im Code einbinden kann/soll.

Wie gesagt: Ich taste mich nach vielen Jahren erst wieder an VBA ran. Und ehrlicherweise waren meine damaligen Versuche einfacher und nur innerhalb von Excel.

Deinen Code kann ich, trotz Einzelschritt,  nur zu einem Bruchteil interpretieren.
Mir scheinen auch noch kleine Fehler in den Schleifen (habe ich angepasst) und nicht genutzte Variablen vorhanden zu sein.

Ich würde mich freuen wenn du mir noch mal in die Spur helfen könntest.

Danke