Bonjour,

Je livre à votre analyse une fonction VBA que j'utilise et dont je n'ai pas trouvé l'equivalent sur le Net.
N'hésitez pas à la critiquer et/ou à l'utiliser si elle vous est utile.

Bon Noël.

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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