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
| Dim ligne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineArbreDescendants()
Set forga = Sheets("BD")
Set f = Sheets("bd")
Tbl = f.Range("A2:F" & f.[A65000].End(xlUp).Row).Value
n = UBound(Tbl)
For Each s In forga.Shapes
If (s.Type = 17 Or s.Type = 1) And s.Name <> "curseur" Then s.Delete
Next
Set débutOrg = forga.Range("j1")
ligne = 0
inth = 90
intv = 36
lig = ActiveCell.Row - 1
If lig > 0 And lig < n Then
créeShapeV Tbl(lig, 1), 1, Tbl(lig, 3) & vbLf & Tbl(lig, 5) & " " & Tbl(lig, 6), f.Cells(2, 1).Interior.Color
DessineAscendants
End If
End Sub
Sub créeShapeV(parent, niv, Attribut, coul) ' procédure récursive
hauteurshape = 33
largeurshape = 160
ligne = ligne + 1
forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = parent
forga.Shapes(parent).Line.ForeColor.SchemeColor = 1
txt = parent & " " & Attribut
With forga.Shapes(parent)
.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 = vbBlack
End With
forga.Shapes(parent).Left = débutOrg.Left + niv * inth
forga.Shapes(parent).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)
forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3
forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 2
End If
If Tbl(i, 2) = parent Then créeShapeV Tbl(i, 1), niv + 1, Tbl(i, 3) & vbLf & Tbl(i, 5) & " " & Tbl(i, 6), f.Cells(2, 1).Interior.Color
Next i
End Sub |
Partager