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
| Sub AjoutCarteDpt()
Dim l_Url As String
Dim Sh As Shape, Img As Object
Dim tArea(50), tZone(50), tCoord() As String, nbZone As Integer
Dim texte, nodept, txt As String
Dim area, zone As String
Dim j, k As Single
For Each Sh In ActiveSheet.Shapes
Sh.Delete
Next
[A1] = InputBox("Département")
ActiveSheet.Range("A1").Select
Set Img = ActiveSheet.Pictures.Insert("http://s599720764.onlinehome.fr/cartocistes/cartographie" & [A1] & "/images/image0.png")
Img.Name = "ImageDept"
nodept = Sheets(1).Range("A1")
l_Url = "http://s599720764.onlinehome.fr/cartocistes/cartographie" & nodept & "/indexOrdi.php?codeRegion=" & nodept & "&codePays=FR"
texte = GetCodeSource(l_Url) 'avec les balises(format html)
' Boucle recherche <area shape="poly" coords=
j = 1
Do
j = InStr(j, texte, "<area shape=""poly"" coords=")
If j = 0 Then Exit Do
txt = Mid(texte, j, 200)
j = j + Len("<area shape=""poly"" coords=") + 1
k = InStr(j, texte, """")
If k > 0 Then
txt = Mid(texte, k, 50) 'Sauter jusqu'à la 1ère zone
If InStr(1, txt, "href") Then
nbZone = nbZone + 1
area = Mid(texte, j, k - j)
tArea(nbZone) = area
' Recherche alt= pour nom de la zone
j = k
j = InStr(j, texte, "alt=")
If j > 0 Then
j = j + 5
k = InStr(j, texte, """")
If k > 0 Then
zone = Mid(texte, j, k - j)
tZone(nbZone) = zone
End If
End If
End If
End If
Loop While j > 0
For i = 1 To nbZone
tCoord = Split(tArea(i), ",")
posx = CInt(tCoord(UBound(tCoord) - 1))
posy = CInt(tCoord(UBound(tCoord)))
With Sheets(1).Shapes.BuildFreeform(msoEditingAuto, posx, posy)
For j = 0 To UBound(tCoord) - 1 Step 2
.AddNodes msoSegmentLine, msoEditingAuto, CInt(tCoord(j)), CInt(tCoord(j + 1))
Next j
.ConvertToShape.Select
End With
Selection.Name = Left(tZone(i), 32)
Next
End Sub
Public Function GetCodeSource(sURL)
Dim Lapage_en_HTML 'variable pour l'object "Microsoft.XMLHTTP"( l'object XML)
Set Lapage_en_HTML = CreateObject("Microsoft.XMLHTTP") 'instancie l'object
Lapage_en_HTML.Open "GET", sURL 'ouvre l'url dans l'object
Lapage_en_HTML.Send
Do: DoEvents: Loop While Lapage_en_HTML.ReadyState <> 4 'attendre que la page soit chargée
'le code source est dans """"Lapage_en_HTML.ResponseText""""
'on créé un object "htmlfile"
With CreateObject("htmlfile")
'on y ecrit le codesource complet
.Write Lapage_en_HTML.ResponseText
End With
GetCodeSource = Lapage_en_HTML.ResponseText
End Function |
