XL 2016 Arborescence/Récursivité (Transformation d'une arborescence en Base de Données)

[laurent950]

Bonjour Le Forum,

Sujet : Arborescence/Récursivité (Transformation d'une arborescence en Base de Données)

Je suis sur un sujet d'arborescence et de Récurcivité :
- J'ai pris l'idée sur le site de Boigontier
* http://boisgontierj.free.fr/
* Sujet : Arborescence/Récursivité
* Son Projet depuis le fichier (NomenclatureEnsemble) dont je m'en suis inspiré
* La base de données que j'ai retravaillée copié du fichier (TreeviewNomenclature)


Mon Travail :
Le Fichier Excel "ArborescenceRecurcivité_V0.xlsm" (ci-joint) est composé :
- 1_DocumentOrigineNonTransformé
° Nota : C'est le document original est à transformer (par VBA Uniquement)
- 4_ResultatFinalAobtenir
° Nota : C'est le résultat à obtenir (avec le Code VBA à créer)
- Laissé pour explication des étapes intermédiaire :
° Nota : Travail fait à la main pour la compréhension du résultat à Obtenir.
Architecture de transformation, Le cheminement :
- 2_FormuleLaisserPourComprendre
- Exemple-Formule-Comprehension-Du-Projet.JPG
et
Les Blocs à repéter :
- 3_ResultatIntemediaireAobtenir
- Exemple-Formule-Comprehension-Du-Projet_Détail Suplmentaire.JPG
- 5_orgaTexte (Hors sujet de travail)
a) PM : Boisgontier la mis sous forme d'arborescence
que j'ai laissé dans le classeur excel pour exemple du rendu en arborescence :
Sur la Feuille (5_orgaTexte)
' Module de @BOISGONTIER
Module VBA "ModTexte" du extrait du fichier NomenclatureEnsemble
de la page Arborescence/Récursivité
du site http://boisgontierj.free.fr/

Explication du travail :
° Je dois transformer le document d'origine pour le remettre sur un nouveau format :
b) Je souhaite le résultat à obtenir sur une seule Ligne :
Suivant le Modèle de la Feuille 4_ResultatFinalAobtenir

Je souhaite réaliser cette tâche uniquement avec le code VBA

J'ai laissé un maximum de détails pour arrivée directement de la feuille :
_ 1_DocumentOrigineNonTransformé (Données d'entrée)
_ 4_ResultatFinalAobtenir (Données Sortie)


J'ai essayé de détailler un maximum pour la compréhension, Je souhaite une procédure VBA uniquement en utilisant
le même principe de récursivité dont à utilisé Boigontier.

j'ai essayé d'adapter mais ce n'est pas encore cela je finalise et je compléterais cette fiche en Poste #1 pour le travail que
j'ai commencé à effectuer pour ce travail.

S'Il y des experts en Arbres / Arborescence / Récursivité pour m'aider à comprendre le concept de la récurcivité et surtout
l'organisation des variables qui sont complexes dans leur réutilisation.

Merci à tous ceux m'apportant des solutions.

Ps : Merci @BOISGONTIER pour tous vos précieux exemple.

Laurent

 

[laurent950]

Bonjour @Dranreb

Complément au Poste #45

Création d'un organigramme hiérarchique dynamique d'une base de données avec shapes.
* Base de données = Feuille Excel : 1_DocumentOrigineNonTransfo
* Organigramme = Feuille Excel : ArborescenceShapes
* Liens Dynamiques = De la Base de Données VERS les Shapes
* ET
* Liens Dynamiques = Des Shapes Vers la Base de Données

' Le Code n'est pas établi avec le concept du modèle de classe de @Dranreb "Qui est très bien" mais pour arriver au résultat qui est un peu complexe à coder, je suis passé par une autre façon de coder, pour cause de difficulté avec la récursivité.

Difficulté :
* positionner les Shapes aux bons endroits dans la feuille.
* Création des Shapes (Unitées/Quantitées/PrixUnitaires/Montants) - Hors récursivité
* Création des Shapes (Unitées/Quantitées/PrixUnitaires/Montants) - PAS DE LIENS (OK)
* Pour ces Shapes (ci-dessus) la largeur de l'objet est unique par Shapes = Distance
* Création des liens "2 Sens" (depuis la base de données Vers Shapes) et Inversement.
* Pour la création des Connecteur il y a une relation de Parent (entre les deux Objets)
* Feuille "ArborescenceShapes" Shapes Cadrillage de feuille "Couleur Blanc".
* Focus sur le Shapes depuis le Lien de la Feuille Base de donnée
* ° Objshape.Select (ne se positionne pas sur l'objet)
* ° FtestPourLien.Range(Objshape.TopLeftCell.Address).Select (Pas très correcte)
* Remplacer par la Solution donné par @Dranreb (ci-dessous)
* ° Objshape.TopLeftCell.Select

Pour test :
* Manque dans la base de données Articles :
* ° 1.1.1.1 (Visuellement indétectable dans l'organigramme) = pas de ligne
* ° 3.3.2.2 (Visuellement indétectable dans l'organigramme) = pas de ligne
* Doublon sur le Numéro de l'Articles :
* ° 2.1.1 (Visuellement détectable dans l'organigramme) = Incohérence dans les Connecteurs !

Au Final :
* Le Top c'est de construire ce même projet mais sous le Mode de "MODULE DE CLASSE" dans l'esprit de @Dranreb qui est vraiment formidable et précis mais je n'ai pas encore le niveau pour arriver à me déplacer dans tous ces exemplaires stockés dans les objets collections et d'utiliser la récuscivité du Poste #45 à @Dranreb pour arriver à recréer ce code déjà complexe.

Conclusion :
* Un très très grand merci à @Dranreb qui m'a permis d'apprendre le modèle objet et d'avoir pu créer ce code.

Liens Objects Shapes : https://excel.developpez.com/faq/?page=Shape

Fichier :
* PresentationShapeArborecenseEnBaseDeDonnéesDranred_V3.xlsm

Code :
Module : ThisWorkbook

Option Explicit
Private Sub Workbook_Open()
   Set ThisApplication = New AppEvents
End Sub

Module Standard : MainShapes_V0

Public ThisApplication As AppEvents
Option Explicit
'https://www.oreilly.com/library/view/programming-excel-with/0596007663/re1355.html
Dim Fbd, FShape As Worksheet
Dim PtDept, AccesCaseBd As Range
Dim TblBd() As Variant
Dim n, Colonne As Integer
Dim inth, intv As Long
Sub DessineShapes_V0()
Dim i, p As Integer
Dim s As Shape
'
' 1) Collecte des information
    Set Fbd = Worksheets("1_DocumentOrigineNonTransfo") ' ..................................................... Feuille de la Base de Données à transformer
    Set FShape = Worksheets("ArborescenceShapes") ' ........................................................... Feuille de L'Arborecense à Créer avec des Shapes
    Set PtDept = FShape.Range(FShape.Cells(1, 6), FShape.Cells(1, 6)) ' ....................................... soit PtDept [F1] Pour Départ Arrborecense en [G2] Feuille = "ArbreAborescence"
    TblBd = Fbd.Range(Fbd.Cells(2, 1), Fbd.Cells(Fbd.Cells(65536, 1).End(xlUp).Row, 6)).Value ' ............... Base de Données à stocké dans la Variable Tableau "TblBd"
    ReDim Preserve TblBd(LBound(TblBd, 1) To UBound(TblBd, 1), LBound(TblBd, 2) To 7) ' ....................... Ajout d'une colonne pour stocker la Racine Parent "Recurcivité"
'
' 2) Créer la Racine Parent (Pour la récurcivité en Colonne 7 du Tableau "TblBd")
'    Titre du document Base de données
'       Nota : Premiére ligne de la base de données (Numéro 0 + Créer un Titre pour cette Arborecense Shapes à Créer)
    n = UBound(TblBd)
        For i = 2 To n
            If TblBd(i, 1) <> "" Then
                If InStr(TblBd(i, 1), ".") = 0 Then
                    TblBd(i, 7) = "0"
                Else
                    p = InStrRev(TblBd(i, 1), ".")
                    TblBd(i, 7) = Left(TblBd(i, 1), p - 1)
                End If
            End If
        Next i
'
' 3) Suppression des tous les Objets Shapes Existant en Feuille "ArborescenceShapes"
        For Each s In FShape.Shapes
            If s.Type = 17 Or s.Type = 1 Then
                s.Delete
            End If
        Next
'
' 4) Paramétrage des variables pour les Objets Shapes à créer sur La Feuille "ArborescenceShapes"
    Colonne = 0
    inth = 90
    intv = 32
    créeShape_V0 CStr(TblBd(1, 1)), 1, TblBd(1, 2)
End Sub
Private Sub créeShape_V0(parent, Niv, Attribut) ' procédure récursive
Dim largeurshape, hauteurshape As Integer
Dim txt, shapePère As String
Dim i As Integer
Dim Tsdetail As Variant
    Tsdetail = Array([{"?","?"}], [{"?","?"}], [{"?","?"}], [{"?","?"}])
'    Tsdetail = Array([{"ShapePére","ShapeParent"}], [{"ShapePére","ShapeParent"}], [{"ShapePére","ShapeParent"}], [{"ShapePére","ShapeParent"}])
' Shape (ShapeParent)
Dim shp As Shape
' Shape Parent (ShapePére)
Dim objParent As Object
'Connecteur (Entre ShapePére & ShapeParent)
Dim conn As Shape
'
' 1) Créer un shape sur la Feuille ""
' Paramétrage pour création des Shapes :
'       * Shapes.AddTextbox (Orientation, Left, Top, Width, Height)
'           ° Orientation (msoTextOrientationHorizontal) : L’orientation de la zone de texte.
'           ° Left (10)                                  : Position (en points)du coin supérieur gauche de la zone de texte par rapport au coin supérieur gauche du document.
'           ° Top (10)                                   : La position (exprimée en points) du coin supérieur gauche de l’image par rapport au haut du document.
'           ° Width (largeurshape = 150)                 : Obtient la largeur de la cellule en points.
'           ° Height (hauteurshape = 27)                 : Hauteur du tableau en points.
    largeurshape = 150: hauteurshape = 27
    Set shp = FShape.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape)
    shp.Name = parent
' Paramétrage des encadrement des Shapes :
        Dim CadreShapes, SansCadreShapes As Byte
            CadreShapes = 22
            SansCadreShapes = 1
    shp.Line.ForeColor.SchemeColor = CadreShapes
'
' 2) Création du texte à insérer dans l'Objet Shapes :
    Attribut = UCase(Mid(Attribut, 1, 1)) & LCase(Mid(Attribut, 2, Len(Attribut)))
    txt = parent & " : " & Attribut ' & vbLf & attribut2
'
' 3) Paramétrage du format du texte à écrire dans l'Objet Shapes
    With shp
        .TextFrame.Characters.Text = txt
        .TextFrame.Characters(Start:=1, Length:=Len(txt)).Font.Size = 12
        .TextFrame.Characters(Start:=1, Length:=Len(parent) + 2).Font.Color = vbRed
        .TextFrame.Characters(Start:=1, Length:=Len(parent) + 2).Font.Bold = True
        .TextFrame.Characters(Start:=Len(parent) + 2, Length:=Len(txt) - Len(parent) + 2).Font.Color = vbBlue
        .TextFrame.Characters(Start:=Len(parent) + 2, Length:=Len(txt) - Len(parent) + 2).Font.Bold = False
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
    End With
'
' 4) Déplacement de l'Objet Shapes pour le positionner au bonne endroit dans la feuille "ArborescenceShapes"
    Colonne = Colonne + 1
    shp.Left = PtDept.Left + Niv * inth
    shp.Top = PtDept.Top + intv * Colonne
    'MsgBox FShape.Shapes(parent).Top
'
' 5 Récurcivité pour créer le Prochain Objet Shapes
' Paramétrage pour création des connecteurs des Shapes :
'       * Shapes.AddConnector (Type, BeginX, BeginY, EndX, EndY)
'           ° Type (msoConnectorElbow) : Type du connecteur à ajouter.
'           ° BeginX (100)             : Position horizontale (en points)du point de départ du connecteur par rapport au coin supérieur gauche du document.
'           ° BeginY (100)             : Position verticale (en points) du point de départ du connecteur par rapport au coin supérieur gauche du document.
'           ° EndX (100)               : Position horizontale (en points) du point de fin du connecteur par rapport au coin supérieur gauche du document.
'           ° EndY (100)               : Position verticale (en points) du point de fin du connecteur par rapport au coin supérieur gauche du document.
    For i = 1 To n
        ' Création des liens des Shapes
        If CStr(TblBd(i, 1)) = shp.Name Then
            CréationDesLien i + 1, shp
        End If
        ' Création des connecteurs
        If CStr(TblBd(i, 1)) <> "" Then
            If CStr(TblBd(i, 1)) = parent And Niv > 1 Then
                Set objParent = FShape.Shapes.Range(TblBd(i, 7))
                Set conn = FShape.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100)
                conn.Line.ForeColor.SchemeColor = 22
                conn.ConnectorFormat.BeginConnect FShape.Shapes(objParent.Name), 3
                conn.ConnectorFormat.EndConnect shp, 2
            End If
            ' Création des prochains Shapes
            If CStr(TblBd(i, 7)) = parent Then
                créeShape_V0 CStr(TblBd(i, 1)), Niv + 1, TblBd(i, 2)
                    If TblBd(i, 1) <> "" And TblBd(i, 3) <> "" Then
                        'MsgBox TblBd(i, 3)
                        Tsdetail(0)(1) = TblBd(i, 1): Tsdetail(0)(2) = TblBd(i, 1) & ".1"
                        Tsdetail(1)(1) = TblBd(i, 1) & ".1": Tsdetail(1)(2) = TblBd(i, 1) & ".2"
                        Tsdetail(2)(1) = TblBd(i, 1) & ".2": Tsdetail(2)(2) = TblBd(i, 1) & ".3"
                        Tsdetail(3)(1) = TblBd(i, 1) & ".3": Tsdetail(3)(2) = TblBd(i, 1) & ".4"
                        ' SousDétailShapesArorescence_V0(ByRef Tsdetail As Variant, ByVal a As Byte, ByVal parent As String, ByVal Colonne As Integer, ByVal Niv As Integer, ByVal i As Integer, ByVal j As Integer, ByVal Largshape As Integer, ByVal Distance As Integer)
                        SousDétailShapesArorescence_V0 Tsdetail, 0, TblBd(i, 1), Colonne, Niv, i, 3, 40, (largeurshape + 15) ' U
                        SousDétailShapesArorescence_V0 Tsdetail, 1, TblBd(i, 1), Colonne, Niv, i, 4, 75, (largeurshape + 15 + (40) + 15) ' Qtes
                        SousDétailShapesArorescence_V0 Tsdetail, 2, TblBd(i, 1), Colonne, Niv, i, 5, 90, (largeurshape + 15 + (40) + 15 + (75) + 15) ' PU
                        SousDétailShapesArorescence_V0 Tsdetail, 3, TblBd(i, 1), Colonne, Niv, i, 6, 120, (largeurshape + 15 + (40) + 15 + (75) + 15 + (90) + 15) ' Mt
                    End If
            End If
        End If
    Next i
'
End Sub
Private Sub SousDétailShapesArorescence_V0(ByRef Tsdetail As Variant, ByVal a As Byte, ByVal parent As String, ByVal Colonne As Integer, ByVal Niv As Integer, ByVal i As Integer, ByVal j As Integer, ByVal Largshape As Integer, ByVal Distance As Integer)
' https://codevba.com/fr/Excel/Shape/Add.htm#ShapesAddTextbox
Dim largeurshape, hauteurshape As Integer

Dim shpAddTextbox As Shape
' Shape (ShapeParent)
Dim shp As Shape
' Shape Parent (ShapePére)
Dim objParent As Object
'Connecteur (Entre ShapePére & ShapeParent)
Dim conn As Shape
' Si case non vide alors : Création des étiquettes Unité / Quantité / Prix Unitaire / Montant HT
' détail dans le code pour les paramétrage :
    largeurshape = Largshape: hauteurshape = 27
    Set shp = FShape.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape)
    Set objParent = FShape.Shapes.Range(Tsdetail(a)(1))
    shp.Name = Tsdetail(a)(2)
    shp.Line.ForeColor.SchemeColor = 22
    With shp
        .TextFrame.Characters.Text = TblBd(i, j)
        .TextFrame.Characters(Start:=1, Length:=Len(TblBd(i, j))).Font.Size = 12
        .TextFrame.Characters(Start:=1, Length:=Len(parent) + 2).Font.Bold = False
        .TextFrame.Characters(Start:=1, Length:=Len(TblBd(i, j))).Font.Color = vbBlue
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
    End With
    shp.Left = PtDept.Left + (Niv + 1) * inth + (Distance)
    shp.Top = PtDept.Top + intv * Colonne
    Set conn = FShape.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100)
    conn.Line.ForeColor.SchemeColor = 22
    conn.ConnectorFormat.BeginConnect FShape.Shapes(objParent.Name), 4
    conn.ConnectorFormat.EndConnect shp, 2
    'FShape.Shapes(Tsdetail(a)(1)).Select: FShape.Shapes(objParent.Name).Select: FShape.Shapes(conn.Name).Select
End Sub
Private Sub CréationDesLien(ByVal i As Integer, ByRef shp As Shape)
' Création du lien
    Dim ObjHyplink As Hyperlink
    Dim ObjHyplinks As Hyperlinks
'
' Création des liens (Click Shapes vers Base de Données excel)
'
    Dim ObjRgn As Range
    Set ObjRgn = Fbd.Range(Fbd.Cells(i, 1), Fbd.Cells(i, 1))
                   Set ObjHyplink = FShape.Hyperlinks.Add _
                                   (Anchor:=FShape.Shapes(CStr(shp.Name)), _
                                    Address:="", _
                                    SubAddress:="'" & Fbd.Name & "'" & "!" & ObjRgn(, 1).Address(0, 0), _
                                    ScreenTip:=CStr(shp.Name))
'
' Création des liens (Click Base de Données excel vers Shapes )
'
                   Set ObjHyplink = FShape.Hyperlinks.Add _
                                   (Anchor:=ObjRgn(, 1), _
                                    Address:="", _
                                    SubAddress:="'" & Fbd.Name & "'" & "!" & ObjRgn(, 1).Address(0, 0), _
                                    ScreenTip:=CStr(shp.Name))
End Sub

Module de Classe : AppEvents

Private WithEvents xlApp As Application
'
Private Sub Class_Initialize()
   Set xlApp = Application
End Sub
'

Private Sub xlApp_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
' Pour rappel c'est un test est cette action sera pour
' interagir avec une autres application que celle d'Ecxel
'
' -------------------------------------------------------------------------
'   Selection du Shapes "Text Dessin 1" au moyen de l'hyperlien de la Cellule C7 de la Feuille Bd
' -------------------------------------------------------------------------

' Suite à l'évenement déclanché
    Dim Objshape As Shape           ' Objet 1 (Shapes de Nom : "Dessin 1")
    Dim NomShapeText As String      ' Objet 2 (Shapes de Nom : "Text Dessin 1")
    Dim FtestPourLien As Worksheet  ' Feuille ou les 2 Objets Shapes sont dessinés
'
' Pour Info :
' Le nom de l'objet 2 est inscrit dans la Variable Objet "Target"
'    * dans l'option Infobul : ScreenTip:=CStr("Text Dessin 1")
' Sous détail (ci dessous)
'    NomShapeText = Target.ScreenTip
' Création de l'objet liée Au Choix* avec : Set Objshape =
'    - *Shapes("Text Dessin 1") OU *Shapes(NomShapeText) OU *Shapes(Target.ScreenTip)
'
' Création de l'objet liée : Objet 2 (Shapes de Nom : "Text Dessin 1")
    Set FtestPourLien = Worksheets("ArborescenceShapes")
    'Set FtestPourLien = Worksheets(Target.parent.Worksheet.Name)
    Set Objshape = FtestPourLien.Shapes(Target.ScreenTip)
' Active Feuil2
    FtestPourLien.Activate
' Selection de cette Objet Liée
    'Objshape.Select
    '  Comment récupérer l'emplacement de la forme automatique dans la feuille ?
    '   * MsgBox Objshape.TopLeftCell.Address & ":" & Objshape.BottomRightCell.Address
    '  FtestPourLien.Range(Objshape.TopLeftCell.Address).Select
    ' Solution @Dranreb
    Objshape.TopLeftCell.Select
End Sub

Laurent