1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
| Option Explicit
Function JD_Distances(CPOST1 As String, CPOST2 As String, Optional Ville1 As String, Optional Ville2 As String, Optional adr1 As String, Optional adr2 As String, Optional Durée As Boolean, Optional Affiche_lien As Boolean, Optional Montre_Plan As Boolean) As Variant
'---------------------------------------------------------------------------------------
' Procedure : JD_Distances
' Date : 25/12/2008
' Auteur : JD
' Contenu : Permet de calculer la distance entre deux adresses (il faut un liaison web active)
'---------------------------------------------------------------------------------------
'
'Exemples d'utilisation:
'
'Distance à partir des codes postaux => JD_Distances("69002", "75015")
'Distance à partir des villes => JD_Distances("", "", "Nevers", "Bourges")
'Distance à partir des adresses => JD_Distances("", "", "Nevers", "Bourges", "rue des charles roy", "rue des poulies")
'Distance + durée => JD_Distances("", "", "Nevers", "Bourges", "rue des charles roy", "rue des poulies", true)
'Lien => JD_Distances("", "", "Nevers", "Bourges", "rue des charles roy", "rue des poulies", true, true)
'Ouverture fenetre => JD_Distances("", "", "Nevers", "Bourges", "rue des charles roy", "rue des poulies", true,true, true)
Dim ie As Object, Temp As String, i As Long, Timing As Date, LesKm As String, DejaRefait As Boolean
On Error GoTo JD_Distances_Error
JD_Distances = ""
On Error GoTo Fin
Temp = "http://maps.google.fr/maps?f=d&"
Temp = Temp & "saddr=" & adr1 & IIf(Ville1 <> "" And adr1 <> "", ",", "") & Ville1 & IIf(Ville1 <> "" And adr1 <> "" And CPOST1 <> "", ",", "") & CPOST1
Temp = Temp & "&daddr=" & adr2 & IIf(Ville2 <> "" And adr2 <> "", ",", "") & Ville2 & IIf(Ville2 <> "" And adr2 <> "" And CPOST2 <> "", ",", "") & CPOST2
If Affiche_lien Then
JD_Distances = Replace(Temp, "URL;", "")
Exit Function
End If
Set ie = CreateObject("internetexplorer.application")
ie.Visible = Montre_Plan
ie.navigate (Temp)
If Montre_Plan Then JD_Distances = "": Exit Function
Refaire:
Timing = Now()
Do While ie.busy
If ((Now() - Timing) * 100000) > 4 Then Exit Do
Loop
JD_Distances = "Erreur de connexion"
Temp = ie.Document.body.innertext
If Len(Temp) < 1000 Then DejaRefait = True: GoTo Refaire
i = InStr(Temp, "Itinéraire en voiture vers ")
If i = 0 And DejaRefait Then GoTo Fin
Temp = Mid(Temp, i, 100)
Temp = Mid(Temp, InStr(Temp, Chr(13)), 100)
Ok:
i = InStr(Temp, "km")
If i = 0 Then JD_Distances = "Itinéraire introuvable": GoTo Fin
Temp = JD_Clean(Temp)
LesKm = Trim(Left(Temp, -1 + i))
If Durée Then
JD_Distances = LesKm & " km en " & Trim(Mid(Temp, i, -1 + InStr(Temp, "minutes")))
GoTo Fin
Else
'Met le bon signe décimal et transforme en valeur numerique utilisable
JD_Distances = Val(Trim(Replace(Replace(LesKm, ",", Mid(1 / 3, 2, 1)), " Km", "")))
End If
Fin:
On Error Resume Next
ie.Quit
Set ie = Nothing
On Error GoTo 0
Exit Function
JD_Distances_Error:
MsgBox "Bug's Info: " & Err.Number & " (" & Err.Description & ")" & vbCrLf & "Procedure:JD_Distances " & vbCrLf & " Module:U_Distances " & vbCrLf & " Ligne: "
Stop
End Function
Function JD_Clean(quoi As String) As String
'idem Clean sous Excel mais marche aussi sous Access
Dim i As Long
For i = 1 To Len(quoi)
If Asc(Mid(quoi, i, 1)) >= 32 And Asc(Mid(quoi, i, 1)) <= 126 Then
JD_Clean = JD_Clean & Mid(quoi, i, 1)
End If
Next i
End Function |
Partager