Dim ligne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrga()
Set forga = Sheets("orga")
Set f = Sheets("bd")
Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
n = UBound(Tbl)
For Each s In forga.Shapes
If s.Type = 17 Or s.Type = 1 Then s.Delete
Next
Set débutOrg = forga.Range("a1")
ligne = 0
inth = 80
intv = 33
créeShape Tbl(1, 1), 1, Tbl(1, 3), f.Cells(2, 1).Interior.Color
End Sub
Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
hauteurshape = 30
largeurshape = 130
ligne = ligne + 1
tt = 0: For k = 1 To Len(parent): tt = tt + (Asc(Mid(parent, k, 1)) - 64) * k: Next k: nomShape = parent & tt
forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = nomShape
forga.Shapes(nomShape).Line.ForeColor.SchemeColor = 1
txt = parent & vbLf & Attribut
With forga.Shapes(nomShape)
.TextFrame.Characters.Text = txt
.TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
.TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
.TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
.Fill.ForeColor.RGB = coul
.TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
End With
forga.Shapes(nomShape).Left = débutOrg.Left + niv * inth
forga.Shapes(nomShape).Top = débutOrg.Top + intv * ligne
For i = 1 To n
If Tbl(i, 1) = parent And niv > 1 Then
shapePère = Tbl(i, 2)
tt = 0: For k = 1 To Len(shapePère): tt = tt + (Asc(Mid(shapePère, k, 1)) - 64) * k: Next k: nomShapePère = shapePère & tt
forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = nomShape & "c"
forga.Shapes(nomShape & "c").Line.ForeColor.SchemeColor = 22
forga.Shapes(nomShape & "c").ConnectorFormat.BeginConnect forga.Shapes(nomShapePère), 3
forga.Shapes(nomShape & "c").ConnectorFormat.EndConnect forga.Shapes(nomShape), 2
End If
If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
Next i
End Sub