[D] Luftlinie.org-Entfernungstool volti

[LCohen]

https://www.clever-excel-forum.de/Thread...#pid204903

Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Type DIST_STRUCT
 Start As String 'Mehrere durch "/" getrennt eingeben
 Ziel  As String
 LDist As String
 FDist As String
End Type

Sub EntfernungErmitteln()
 Dim tDist As DIST_STRUCT
 With tDist
  .Start = "Frankfurt": .Ziel = "München"
  GetDistance tDist
  MsgBox "Die Entfernung zwischen" & vbCrLf _
      & .Start & vbCrLf & "und" & vbCrLf _
      & .Ziel & vbCrLf & "beträgt " & .LDist & " km." & vbCrLf _
      & "Die Fahrstrecke beträgt " & .FDist & "!", vbInformation, "Entfernung ermitteln"
 End With
End Sub

Sub GetDistance(tDist As DIST_STRUCT)
 Dim oNode As Object
 With CreateObject("InternetExplorer.Application")
  .navigate "http://www.luftlinie.org"      'Zur Url surfen
  While Not .readyState = 4: DoEvents: Wend 'Warten bis Seite geladen ist

  With .document
   Set oN‌ode = .getElementById("start")
   If Not oNode Is Nothing Then
    oNode.value = tDist.Start
    Set oN‌ode = .getElementById("end")
    On Error Resume Next
    If Not oNode Is Nothing Then
      oNode.value = tDist.Ziel
      Set oN‌ode = .getElementById("calcDistance")
      If Not oNode Is Nothing Then oNode.Click
      Do
        Sleep 100
        Set oN‌ode = Nothing
        Set oN‌ode = .getElementById("strck")
        If Not oNode Is Nothing Then
          If Not oNode.outerText Like "*--*" Then Exit Do
        End If
        DoEvents
      Loop
      tDist.LDist = .getElementsByClassName("value km")(0).outerText
      tDist.FDist = .getElementById("strck").outerText
      tDist.Start = tDist.Start & " " & .getElementsByClassName("regions")(0).outerText
      tDist.Ziel = tDist.Ziel & " " & .getElementsByClassName("regions")(2).outerText
    End If      'End
   End If      'Start
  End With
  .Quit        'IE schließen
 End With
End Sub

____________________________________________________________
Als Tabellenfunktion mit dynamischer Breite (ab xl2013, wenn als Array abgeschlossen; sonst ab xl365), ersetzt die gleichnamige Sub oben:

Function EntfernungErmitteln(a, b)
Dim tDist As DIST_STRUCT
With tDist
  .Start = a: .Ziel = b
  GetDistance tDist
  EntfernungErmitteln = Replace(.Start, " ", "_") & " " & Replace(.Ziel, " ", "_") & " " & .LDist & " " & .FDist
End With
End Function

Stehen in A1:B1 Start und Ziel, resultieren in C1:F1: StartGenau, ZielGenau, Luftlinie, Entfernung:

C1: =MTRANS(XMLFILTERN(WECHSELN("<a><b>"&WECHSELN(EntfernungErmitteln(A1;B1);" km";)&"</b></a>";" ";"</b><b>");"//b"))

Will man nur letztere beide Zahlen haben, dann:

C1: =INDEX(MTRANS(XMLFILTERN(WECHSELN("<a><b>"&WECHSELN(EntfernungErmitteln(A1;B1);" km";)&"</b></a>";" ";"</b><b>");"//b"));{3.4})