Sub DESSINER_ORGANIGRAME()
Dim ligne As Double
Dim STR
ligne = 1
'Définition des paramètres de travail
Set GRAPHE = Sheets("GRAPHE")
Set donnee = Sheets("DONNEE")
Tbl = donnee.Range("A2:E" & donnee.[A65000].End(xlUp).Row).Value
CODE_STR = donnee.Cells(ActiveCell.Row, 1).Value
n = UBound(Tbl)
' Supprimer les graphes déjà effectués dans les traitements précédents
For Each s In GRAPHE.Shapes
If s.Type = 17 Or s.Type = 1 Then s.Delete
Next
' Définition des tailles des graphes à créer
colonne = 0
inth = 180
intv = 32
'Créer un shape pour la structure sélectionnée
CREER_SHAPE CODE_STR, ligne
'Boucle pour créer le shape pour les sous structure niveau 1
For i = 1 To NBRE_DIRECT_RATTACHE(CODE_STR)
ligne = ligne + i - 1
STR = STR_RATTACHE_i(CODE_STR, i)
CREER_SHAPE STR, ligne
connect_str "C" & CODE_STR, "C" & STR 'Connecter les structures
'Boucle pour créer le shape pour les sous structure niveau 2
For j = 1 To NBRE_DIRECT_RATTACHE(STR)
ligne = ligne + j - 1
CREER_SHAPE STR_RATTACHE_i(STR, j), ligne
connect_str "C" & STR, "C" & STR_RATTACHE_i(STR, j) 'Connecter les structures
'Boucle pour créer le shape pour les sous structure niveau 3
If j = NBRE_DIRECT_RATTACHE(STR) Then
ligne = ligne - j
Else
ligne = ligne - j + 1
End If
Next
ligne = ligne + NBRE_DIRECT_RATTACHE(STR) - i + 1
Next
End Sub
'Fonction utilisée : Nombre de structures rattachées directement
Function NBRE_DIRECT_RATTACHE(ByVal CODE_STR As Double)
'Retourne le nombre de structure rattaché
Dim Plage As Range
With Worksheets("donnee") 'en colonne "A" à partir de A2
Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
NBRE_DIRECT_RATTACHE = Application.CountIf(Plage, CODE_STR)
End Function
'Fonction utilisée : CREER_SHAPE
Function CREER_SHAPE(ByVal Code_s As Long, ByVal ligne As Integer)
Set débutOrg = GRAPHE.Range("b2")
'ligne = ligne + i - 1
hauteurshape = 25
largeurshape = 160
If ExisteShape("C" & Code_s) Then Exit Function
GRAPHE.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, Hauteur(Code_s)).Name = "C" & Code_s
GRAPHE.Shapes("C" & Code_s).Line.ForeColor.SchemeColor = 1
txt = STR(Code_s)
With GRAPHE.Shapes("C" & Code_s)
.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(txt)).Font.Bold = True
.Fill.ForeColor.RGB = colorer(Code_s)
.TextFrame.Characters(Start:=1, Length:=Len(txt)).Font.Color = vbBlack
End With
GRAPHE.Shapes("C" & Code_s).Left = débutOrg.Left + (NIV_STR(Code_s) - NIV_STR(CODE_STR)) * inth
GRAPHE.Shapes("C" & Code_s).Top = débutOrg.Top + intv * ligne
End Function
'Fonction utilisée : Connecter les structures dessinées
'La principale fonctionnalité de cette fonction est « .Shapes.AddConnector » destinée à connecter deux shapes :
Function connect_str(ByVal cPere As String, ByVal cFils As String)
Dim coul_ligne
coul_ligne = Sheets("DONNEE").Range("I2").Value
GRAPHE.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = cPere & cFils
GRAPHE.Shapes(cPere & cFils).Line.ForeColor.SchemeColor = coul_ligne
GRAPHE.Shapes(cPere & cFils).ConnectorFormat.BeginConnect GRAPHE.Shapes(cPere), 4
GRAPHE.Shapes(cPere & cFils).ConnectorFormat.EndConnect GRAPHE.Shapes(cFils), 2
End Function
'Fonction utilisée : retourner les structures rattachées à chaque structure
Function STR_RATTACHE_i(ByVal STR_C As Double, ByVal rang As Integer)
'Renvoi les ligne des differentes structure rattaché
Set f = Sheets("DONNEE")
Dim lig_, col_ As Double
Dim fil() As Double
Dim Plage As Range
Dim Cel As Range
With Worksheets("donnee")
'en colonne "A" à partir de A2
Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
If rang <= NBRE_DIRECT_RATTACHE(STR_C) Then
i = 0
For Each Cel In Plage
lig_ = Cel.Row
col_ = Cel.Column
If f.Cells(lig_, 4).Value = STR_C Then
i = i + 1
ReDim Preserve fil(i)
fil(i) = lig_ 'f.Cells(lig_, 1).Value
End If
Next
STR_RATTACHE_i = f.Cells(fil(rang), 1).Value
Else
MsgBox "Rang : " & rang & " Supérieur à la taille : " & NBRE_DIRECT_RATTACHE(STR_C)
End If
End Function
'Fonction utilisée : colorer les shapes en fonction du niveau de la structure
Function colorer(ByVal Code_s As Long)
Select Case TYP_STR(Code_s)
Case "CENTRAL"
colorer = donnee.Cells(2, 7).Interior.Color
Case "DIRECTION"
colorer = donnee.Cells(3, 7).Interior.Color
Case "DIVISION"
colorer = donnee.Cells(4, 7).Interior.Color
Case "DG"
colorer = donnee.Cells(5, 7).Interior.Color
Case "SERVICE"
colorer = donnee.Cells(6, 7).Interior.Color
End Select
End Function
'Fonction utilisée : déterminer le type structure
Function TYP_STR(ByVal CODE_STR As Double)
Dim Plage As Range
With Worksheets("donnee") 'en colonne "A" à partir de A2
Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With
TYP_STR = WorksheetFunction.VLookup(CODE_STR, Plage, 2, False)
End Function
'Fonction utilisée : déterminer la structure en fonction de son code
Function STR(ByVal CODE_STR As Double)
Dim Plage As Range
With Worksheets("donnee") 'en colonne "A" à partir de A2
Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp))
End With
STR = WorksheetFunction.VLookup(CODE_STR, Plage, 3, False)
End Function
Function ExisteShape(nomshape)
For Each s In ActiveSheet.Shapes
If s.Name = nomshape Then ExisteShape = True
Next s
End Function
[code]
[/spoiler]
