Google Maps - Strassenname ermitteln... [ZIP, 60 KB]
'Code: Eine Adresse
Option Explicit
Private Enum IE_READYSTATE
Uninitialised = 0
Loading = 1
Loaded = 2
Interactive = 3
Complete = 4
End Enum
Sub Test()
Dim wksSheet As Worksheet
Dim objResult As Object
Dim objIEApp As Object
Dim strFirma As String
Dim varArr As Variant
Dim strPLZ As String
Dim strOrt As String
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
With wksSheet
strFirma = .Cells(1, 1).Value
strPLZ = .Cells(1, 2).Value
strOrt = .Cells(1, 3).Value
End With
Set objIEApp = CreateObject("InternetExplorer.Application")
With objIEApp
.Visible = False ' True = sichtbar
.Navigate2 "http://maps.google.com/maps?q=" & _
strFirma & " " & strPLZ & " " & strOrt
Do Until objIEApp.readyState = _
IE_READYSTATE.Complete: DoEvents: Loop
Set objResult = .Document.getElementById("adr")
If Not objResult Is Nothing Then
varArr = Split(objResult.innerText, ",")
wksSheet.Cells(1, 4).Value = varArr(0)
Else
wksSheet.Cells(1, 4).Value = "Kein Ergebnis!"
End If
End With
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
If Not objIEApp Is Nothing Then objIEApp.Quit
Set objIEApp = Nothing
Set wksSheet = Nothing
End Sub
'Code: Alle Adressen
Option Explicit
Private Enum IE_READYSTATE
Uninitialised = 0
Loading = 1
Loaded = 2
Interactive = 3
Complete = 4
End Enum
Sub Test_1()
Dim wksSheet As Worksheet
Dim objResult As Object
Dim objIEApp As Object
Dim strFirma As String
Dim varArr As Variant
Dim strPLZ As String
Dim strOrt As String
Dim lngRow As Long
On Error GoTo Fin
Set objIEApp = CreateObject("InternetExplorer.Application")
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
With wksSheet
lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
.Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With objIEApp
.Visible = False ' True = sichtbar
For lngRow = 1 To lngRow
With wksSheet
strFirma = .Cells(lngRow, 1).Value
strPLZ = .Cells(lngRow, 2).Value
strOrt = .Cells(lngRow, 3).Value
End With
.Navigate2 "http://maps.google.com/maps?q=" & _
strFirma & " " & strPLZ & " " & strOrt
Do Until objIEApp.readyState = _
IE_READYSTATE.Complete: DoEvents: Loop
Set objResult = .Document.getElementById("adr")
With wksSheet
If Not objResult Is Nothing Then
varArr = Split(objResult.innerText, ",")
.Cells(lngRow, 4).Value = varArr(0)
Else
.Visible = True
.Cells(lngRow, 4).Value = "Kein Ergebnis!"
End If
End With
Next lngRow
End With
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
If Not objIEApp Is Nothing Then objIEApp.Quit
Set objIEApp = Nothing
Set wksSheet = Nothing
End Sub
