Dessiner carte depuis page web

**geracole** · 18/01/2019, 12h32

Bonjour,
Je ne sais pas trop où classer cette discussion, peut-être le superviseur la déplacera-t'il dans un autre forum.
Je développe en Excel une appli qui va lire une page Web et qui récupère une image et les coordonnées de zones pour les redessiner sur une feuille Exel.
J'arrive à faire tout ceci avec le source :

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
 
 
 
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

Cela marche parfaitement avec la page Savoie mais pas avec celle de l'Isère, les forms dessinées ne sont pas à l'échelle de la carte, importée comme image.
D'où cela vient-il ?
N'étant pas très fort en html, je n'ai pas trouvé la cause du changement d'échelle.
Sur la page affichée depuis le web, c'est Ok mais pas sur ma feuille Excel.

Sans le code fourni, indiquer 38 pour la page Isère qui pose problème, et 73 pour la Savoie (pour ceux qui ont oublié leurs départements

Merci d'avance.

**EricDgn** · 01/02/2019, 15h16

Bonjour,

Il apparait que département et zones ne sont pas à la même échelle.
La solution la plus simple est de mettre l'image du département à la même échelle, comme dans ce code.

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
86
87
88
Sub AjoutCarteDpt()
   Dim l_Url As String
   Dim Sh As Shape, Img As Object
   Dim tArea(50) As String, tZone(50) As String, tCoord() As String, nbZone As Integer
   Dim texte As String, nodept As String, txt As String
   Dim area As String, zone As String
   Dim i As Integer, j As Single, k As Single
   Dim posX As Integer, posY As Integer
   Dim X As Integer, Y As Integer
   Dim Xmax As Integer, Ymax As Integer
   Dim Xmin As Integer, Ymin As Integer
 
   For Each Sh In ActiveSheet.Shapes
      Sh.Delete
   Next
 
    [A1] = InputBox("Département")
    nodept = [A1]
    [A1].Select
    Debug.Print [A1]
 
    l_Url = "http://s599720764.onlinehome.fr/cartocistes/cartographie" & nodept & "/images/image0.png"
    'Debug.Print l_Url
    Set Img = ActiveSheet.Pictures.Insert(l_Url)
    Img.Name = "ImageDept"
    Debug.Print Img.Width, Img.Height
 
    l_Url = "http://s599720764.onlinehome.fr/cartocistes/cartographie" & nodept & "/indexOrdi.php?codeRegion=" & nodept & "&codePays=FR"
    'Debug.Print l_Url
    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
 
    Xmax = 0
    Ymax = 0
    Xmin = 999
    Ymin = 999
    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
                X = CInt(tCoord(j))
                Y = CInt(tCoord(j + 1))
                If X > Xmax Then Xmax = X
                If Y > Ymax Then Ymax = Y
                If X < Xmin Then Xmin = X
                If Y < Ymin Then Ymin = Y
                .AddNodes msoSegmentLine, msoEditingAuto, X, Y
            Next j
            .ConvertToShape.Select
        End With
        Selection.Name = Left(tZone(i), 32)
    Next
   Debug.Print Xmax, Ymax
   With Img.ShapeRange
      .Width = Xmin + Xmax
      .Height = Ymin + Ymax
   End With
 End Sub

Il serait aussi possible de faire l'inverse, mettre les zones à l'échelle du département.

Bonne continuation.

**Philippe Tulliez** · 01/02/2019, 16h27

Bonjour,
Quel est le format de la carte ?
Personnellement, j'utilise le WMF (Windows Meta File) et à ce moment là, rien de plus simple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
  Dim sh As Shape
  Set sh = Feuil2.Shapes(1)
  sh.Ungroup

**geracole** · 01/02/2019, 18h43

Envoyé par EricDgn

Bonjour,
Il serait aussi possible de faire l'inverse, mettre les zones à l'échelle du département.

Merci EricDgn, j'avais cherché dans ce sens, mais pas réussi a trouver une formule générale.

Vu la taille de l'ensemble, il serait mieux de mette les zones à la taille de l'image. Comment ferais-tu cela. J'ai tenté d'appliquer une réduction à chaque zone, mais ça ne va pas. Les zones sont réduites mais l'étalement reste le même, en plus de la réduction de taille, il faut aussi les déplacer vers le haut. Je ne trouve pas la bonne façon de faire.
J'ai essayé de tout grouper les zones , réduire et dé-grouper, c'est bon mais je n'arrive pas à savoir quel est le % de réduction à appliquer.
Je pourrais aussi ajouter à ton code le groupage de zones + l'image, réduire et dégrouper, mais je pense qu'il y a mieux à faire.
Pourrais-tu m'indiquer comment tu ferais pour réduire les zones à la taille de l'image.
Merci.

**EricDgn** · 02/02/2019, 11h52

Bonjour,

Voilà, pour ajuster les zones à la carte:

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Sub AjoutCarteDpt_A()
   Dim l_Url As String
   Dim Sh As Shape, Img As Object
   Dim tArea(50) As String, tZone(50) As String, tCoord() As String, nbZone As Integer
   Dim texte As String, nodept As String, txt As String
   Dim area As String, zone As String
   Dim i As Integer, j As Integer, k As Integer
   Dim posX As Integer, posY As Integer
   Dim X As Integer, Y As Integer
   Dim Xmax As Integer, Ymax As Integer
   Dim Xmin As Integer, Ymin As Integer
   Dim kX As Single, kY As Single
 
   For Each Sh In ActiveSheet.Shapes
      Sh.Delete
   Next
 
    [A1] = InputBox("Département")
    nodept = [A1]
    [A1].Select
    Debug.Print [A1]
 
    l_Url = "http://s599720764.onlinehome.fr/cartocistes/cartographie" & nodept & "/images/image0.png"
    'Debug.Print l_Url
    Set Img = ActiveSheet.Pictures.Insert(l_Url)
    Img.Name = "ImageDept"
    Debug.Print Img.Width, Img.Height
 
    l_Url = "http://s599720764.onlinehome.fr/cartocistes/cartographie" & nodept & "/indexOrdi.php?codeRegion=" & nodept & "&codePays=FR"
    'Debug.Print l_Url
    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
 
    Xmax = 0
    Ymax = 0
    Xmin = 999
    Ymin = 999
    '--- recherche Xmax, Ymax
    For i = 1 To nbZone
        tCoord = Split(tArea(i), ",")
        posX = CInt(tCoord(UBound(tCoord) - 1))
        posY = CInt(tCoord(UBound(tCoord)))
         For j = 0 To UBound(tCoord) - 1 Step 2
             X = CInt(tCoord(j))
             Y = CInt(tCoord(j + 1))
             If X > Xmax Then Xmax = X
             If Y > Ymax Then Ymax = Y
             If X < Xmin Then Xmin = X
             If Y < Ymin Then Ymin = Y
         Next j
    Next i
    '--- calcul coefficients d'ajustment
   With Img.ShapeRange
      kX = .Width / (Xmax + Xmin)      '--- taille zones ok
      kY = .Height / (Ymax + Ymin)
   End With
   Debug.Print Xmin, Ymin, Xmax, Ymax, kX, kY
    '--- tracé zones ajustées
    For i = 1 To nbZone
        tCoord = Split(tArea(i), ",")
        posX = CInt(tCoord(UBound(tCoord) - 1)) * kX
        posY = CInt(tCoord(UBound(tCoord))) * kY
        With Sheets(1).Shapes.BuildFreeform(msoEditingAuto, posX, posY)
            For j = 0 To UBound(tCoord) - 1 Step 2
                X = CInt(tCoord(j)) * kX
                Y = CInt(tCoord(j + 1)) * kY
                .AddNodes msoSegmentLine, msoEditingAuto, X, Y
            Next j
            .ConvertToShape.Select
        End With
        Selection.Name = Left(tZone(i), 32)
     Next
 End Sub

Bonne continuation.

**geracole** · 02/02/2019, 18h25

Super, c'est exactement ce qu'il fallait.
Merci.

Dessiner carte depuis page web [XL-2003]

Excel

Discussions similaires

Partager

Partager