XL 2010 Organigramme automatique non centré

[fablog]

Bonjour,

J'ai un souci avec la création automatique d'organigrammes avec Excel. J'ai utilisé le code VBA de Boisgontier provenant de ce fichier.
Quand j'utilise son fichier en activant la macro, je n'ai pas un organigramme qui se centre en fonction du niveau supérieur, mais cela fait une sorte d'alignement à droite. Quand j'intègre beaucoup d'éléments à cet organigramme, cela me fait un tableau très étiré en largeur donc peu lisible.

Je ne sais pas programmer en VBA même si je commence à m'y retrouver. Pourriez-vous m'aider à modifier les macros ci-dessous pour centrer l'organigramme svp?

Dim colonne, débutOrg, forga, inth, intv, Tbl(), n
Sub DessineOrgaClic()
  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("A10")
  colonne = 0
  inth = 55
  intv = 35
  créeShape Tbl(1, 1), 1, Tbl(1, 3)
End Sub
Sub créeShape(parent, niv, Attribut) ' procédure récursive
  hauteurshape = 20
  largeurshape = 50
  forga.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 22
  txt = parent
  With forga.Shapes(parent)
   .TextFrame.Characters.Text = txt
   .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 7
   .OnAction = "detail"
  End With
  colonne = colonne + 1
  forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
  forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  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), 1
    End If
    If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3)
  Next i
End Sub
Sub detail()
  On Error Resume Next
  For Each s In ActiveSheet.Shapes
     s.Fill.ForeColor.RGB = RGB(255, 255, 255)
  Next s
  On Error GoTo 0
  Set fbd = Sheets("bd")
  s = Application.Caller
  Set result = fbd.[a:a].Find(what:=s)
  [d2] = result
  [d3] = result.Offset(, 1)
  [d4] = result.Offset(, 2)
  [d5] = result.Offset(, 3)
  [d6] = result.Offset(, 4)
  ActiveSheet.Shapes(s).Fill.ForeColor.RGB = RGB(255, 0, 0)
End Sub

Merci et bonne journée!

Fabien

 

[fablog]

Bonjour tout le monde,

@BOISGONTIER vous n'avez pas la solution à mon problème? Peut-être Est-ce plus complexe que cela en a l'air