OFFICE : Dessiner une carte de France avec les fonctions de dessins

'---------------------------------------------------------------------------------------------------------
' Importation du fichier SVG des départements et création des formes libres
'---------------------------------------------------------------------------------------------------------
Function CreateShapes()
Dim oSheet As Excel.Worksheet ' Feuille de travail
Dim lLine As Long ' Compteur de lignes
Dim lCoord As String ' Coordonnées du département
Dim lCoordArray As Variant ' Coordonnées du département en tableau
Dim lCptCoord As Long ' Compteur pour parcourir les coordonnées
Dim lNbShape As Long ' Nombre de formes créées
Dim lShapeRange() ' Tableaux des noms de formes créées pour fonction Group
Dim loFreeformBuilder As Excel.FreeformBuilder 'Constructeur de forme libre
            
' Feuille de données
Set oSheet = Sheets("Departements")
' Parcourt la feuille des données
For lLine = 1 To 96
    ' Coordonnées
    lCoord = oSheet.Cells(lLine, 1)
    ' Mise en forme des coordonnées
    lCoord = Replace(lCoord, ",", " ")
    ' Crée un tableau à partir de la chaîne de caractères
    lCoordArray = Split(lCoord, " ")
    ' Initialise le compteur
    lCptCoord = LBound(lCoordArray)
    Do
        Select Case lCoordArray(lCptCoord)
        Case "M" ' Point de départ
            ' Crée un constructeur de "forme libre" pour le département courant sur la feuille oSheet
            Set loFreeformBuilder = oSheet.Shapes.BuildFreeform(msoEditingCorner, _
			Val(lCoordArray(lCptCoord + 1)) * 10, Val(lCoordArray(lCptCoord + 2)) * 10)
            lCptCoord = lCptCoord + 3
        Case "L" ' Segment
            loFreeformBuilder.AddNodes msoSegmentLine, msoEditingAuto, _
			Val(lCoordArray(lCptCoord + 1)) * 10, Val(lCoordArray(lCptCoord + 2)) * 10
            lCptCoord = lCptCoord + 3
        Case "C" ' Courbe
            loFreeformBuilder.AddNodes msoSegmentCurve, msoEditingCorner, _
			Val(lCoordArray(lCptCoord + 1)) * 10, Val(lCoordArray(lCptCoord + 2)) * 10, _
			Val(lCoordArray(lCptCoord + 3)) * 10, Val(lCoordArray(lCptCoord + 4)) * 10, _
			Val(lCoordArray(lCptCoord + 5)) * 10, Val(lCoordArray(lCptCoord + 6)) * 10
            lCptCoord = lCptCoord + 7
        Case "z" ' Fin de la forme
            ' Convertit le Constructeur en Forme
            With loFreeformBuilder.ConvertToShape
	' Identifiant du département
                .Name = oSheet.Cells(lLine, 2)
                ' Incrémente le nombre de formes créées
                lNbShape = lNbShape + 1
                ' Redimensionne le tableau de formes créées
                ReDim Preserve lShapeRange(1 To lNbShape)
                ' Ajoute le nom de la forme au tableau pour groupement
                lShapeRange(lNbShape) = .Name
            End With
            ' Libère l'objet constructeur
            Set loFreeformBuilder = Nothing
            ' Sort de la boucle de traitement des coordonnées
            Exit Do
        End Select
    Loop
Next
' Groupe les départements dans une forme
With oSheet.Shapes.Range(lShapeRange).Group
    .Name = "CarteFrance"
    .ScaleHeight 0.05, msoFalse
    .ScaleWidth 0.05, msoFalse
    .LockAspectRatio = msoTrue
End With
End Function

'---------------------------------------------------------------------------------------------------------
' Importation du fichier SVG des départements et création des formes libres
'---------------------------------------------------------------------------------------------------------
Function ImportSVG()
Dim loXml As New MSXML2.DOMDocument ' Objet XML
Dim loElt As MSXML2.IXMLDOMElement ' Element XML
Dim loAttr As MSXML2.IXMLDOMAttribute ' Attribut de l'élément XML
Dim loDep As MSXML2.IXMLDOMElement ' Element XML Département
Dim loAttrDep As MSXML2.IXMLDOMAttribute ' Attribut de l'élément Département
Dim lId As String ' Id du département
Dim lName As String ' Nom du département
Dim lCoord As String ' Coordonnées du département
Dim lCoordArray As Variant ' Coordonnées du département en tableau
Dim lCptCoord As Long ' Compteur pour parcourir les coordonnées
Dim lNbShape As Long ' Nombre de formes créées
Dim lShapeRange() ' Tableaux des noms de formes créées pour fonction Group
Dim loFreeformBuilder As Word.FreeformBuilder 'Constructeur de forme libre
Dim oDoc As Word.Document ' Document sur laquelle la carte est créée
            
' Objet document
Set oDoc = ThisDocument
' Chargement du fichier SVG contenant les départements
loXml.Load ThisDocument.Path & "\Départements_et_régions_de_France.svg"
' Parcourt les éléments du XML
For Each loElt In loXml.DocumentElement.ChildNodes
    ' Les départements sont dans un noeud de nom = g
    If loElt.nodeName = "g" Then
        ' Parcourt les attributs de l'élément
        For Each loAttr In loElt.Attributes
            ' Teste si l'attribut "inkscape:label" est égale à "Département"
            ' => cet élément contient les coordonnées des départements
            If loAttr.Name = "inkscape:label" And loAttr.Value = "Département" Then
                ' Parcourt les départements
                For Each loDep In loElt.ChildNodes
                    ' Parcourt les attributs de chaque élément = chaque département
                    For Each loAttrDep In loDep.Attributes
                        ' Conserve les attributs utiles dans des variables
                        Select Case loAttrDep.Name
                            Case "id" ' Identifiant
                                lId = loAttrDep.Value
                            Case "inkscape:label" ' Nom
                                lName = loAttrDep.Value
                            Case "d" ' Chemin = Coordonnées
                                lCoord = loAttrDep.Value
                        End Select
                    Next
                    ' Mise en forme des coordonnées
                    lCoord = Replace(lCoord, ",", " ")
                    ' Crée un tableau à partir de la chaîne de caractères
                    lCoordArray = Split(lCoord, " ")
                    ' Initialise le compteur
                    lCptCoord = LBound(lCoordArray)
                    Do
                        Select Case lCoordArray(lCptCoord)
                        Case "M" ' Point de départ
                            ' Crée un constructeur de "forme libre" pour le département courant sur le document oDoc
                            Set loFreeformBuilder = oDoc.Shapes.BuildFreeform(msoEditingCorner, _
							Val(lCoordArray(lCptCoord + 1)), Val(lCoordArray(lCptCoord + 2)))
                            lCptCoord = lCptCoord + 3
                        Case "L" ' Segment
                            loFreeformBuilder.AddNodes msoSegmentLine, msoEditingAuto, _
							Val(lCoordArray(lCptCoord + 1)), Val(lCoordArray(lCptCoord + 2))
                        lCptCoord = lCptCoord + 3
                        Case "C" ' Courbe
                            loFreeformBuilder.AddNodes msoSegmentCurve, msoEditingCorner, _
							Val(lCoordArray(lCptCoord + 1)), Val(lCoordArray(lCptCoord + 2)), _
							Val(lCoordArray(lCptCoord + 3)), Val(lCoordArray(lCptCoord + 4)), _
							Val(lCoordArray(lCptCoord + 5)), Val(lCoordArray(lCptCoord + 6))
                            lCptCoord = lCptCoord + 7
                        Case "z" ' Fin de la forme
                            ' Convertit le Constructeur en Forme
                            With loFreeformBuilder.ConvertToShape
                                ' Identifiant du département
                                .Name = lId
                                ' Incrémente le nombre de formes créées
                                lNbShape = lNbShape + 1
                                ' Redimensionne le tableau de formes créées
                                ReDim Preserve lShapeRange(1 To lNbShape)
                                ' Ajoute le nom de la forme au tableau pour groupement
                                lShapeRange(lNbShape) = .Name
                            End With
                            ' Libère l'objet constructeur
                            Set loFreeformBuilder = Nothing
                            ' Sort de la boucle de traitement des coordonnées
                            Exit Do
                        End Select
                    Loop
                Next
            End If
        Next
    End If
Next
' Groupe les départements dans une forme
With oDoc.Shapes.Range(lShapeRange).Group
    .Name = "CarteFrance"
    .ScaleHeight 0.5, msoFalse
    .ScaleWidth 0.5, msoFalse
    .LockAspectRatio = msoTrue
End With
            
End Function