SHAPE oh! my SHAPE

[xhudi69]

Bonsoir le Forum,

A l'aide de l'UserForm, vous sélectionné un Shape bleu puis "sélection", puis vous sélectionné un autre Shape bleu puis "sélection" et ensuite "relier", là ça fonctionne.

Mais si vous sélectionné un Shape bleu et un Shape bleu/rouge, cela ne fonctionne pas , car le Shape bleu/rouge a été groupé. avez-vous une solution, car je démarre dans les Shapes pour un log à mon travail.

Grand merci à vous tous pour le temps passé.

@+

 

[xhudi69]

Re : SHAPE oh! my SHAPE

Bonjour BOISGONTIER, le Forum

je n'en espérais pas tant, pour mon début dans les Shapes, un énorme merci, avec tout cela, je vais réellement avancé.

Merci mille fois

@+

 

[BOISGONTIER]

Re : SHAPE oh! my SHAPE

Affichage des images des groupes choisis dans le formulaire.

http://boisgontierjacques.free.fr/fichiers/Images/ConnectionGroupeForm.xlsm

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("feuil1")
  For Each c In f.Shapes
    If c.Type = 6 Then
      Me.ComboBox1.AddItem c.Name
      Me.ComboBox2.AddItem c.Name
    End If
  Next c
  afficheNomsgroupe
End Sub

Private Sub ComboBox1_Change()
  Set s = f.Shapes(CStr(Me.ComboBox1))
  s.CopyPicture
  f.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
  razCoul
  Range(s.TopLeftCell.Address).Offset(-1).Font.ColorIndex = 3
End Sub

Private Sub ComboBox2_Change()
  Set s = f.Shapes(CStr(Me.ComboBox2))
  s.CopyPicture
  f.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  Me.Image2.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
  razCoul
  Range(s.TopLeftCell.Address).Offset(-1).Font.ColorIndex = 3
End Sub

Private Sub B_connext_Click()
  groupe1 = Me.ComboBox1
  groupe2 = Me.ComboBox2
  nomshape1 = Rectangle(f, groupe1)
  nomShape2 = Rectangle(f, groupe2)
  nomCnn = "cnn" & groupe1 & groupe2
  f.Shapes.AddConnector(msoConnectorElbow, 10, 10, 10, 10).Name = nomCnn
  If ligne(f, groupe2) > ligne(f, groupe1) Then typeCnn1 = 3: typeCnn2 = 1 Else typeCnn1 = 1: typeCnn2 = 3
  f.Shapes(nomCnn).ConnectorFormat.BeginConnect f.Shapes(nomshape1), typeCnn1
  f.Shapes(nomCnn).ConnectorFormat.EndConnect f.Shapes(nomShape2), typeCnn2
  Range(f.Shapes(groupe1).TopLeftCell.Address).Offset(-1).Font.ColorIndex = vbBlack
  Range(f.Shapes(groupe2).TopLeftCell.Address).Offset(-1).Font.ColorIndex = vbBlack
End Sub

Private Sub B_sup_cnn_Click()
  On Error Resume Next
  groupe1 = Me.ComboBox1
  groupe2 = Me.ComboBox2
  nomshape1 = Rectangle(f, groupe1)
  nomShape2 = Rectangle(f, groupe2)
  nomCnn = "cnn" & groupe1 & groupe2
  f.Shapes.Range(nomCnn).Delete
  Range(f.Shapes(groupe1).TopLeftCell.Address).Offset(-1).Font.ColorIndex = vbBlack
  Range(f.Shapes(groupe2).TopLeftCell.Address).Offset(-1).Font.ColorIndex = vbBlack
End Sub

Function Rectangle(f, nomGroupe)
  For i = 1 To f.Shapes(nomGroupe).GroupItems.Count
   If f.Shapes(nomGroupe).GroupItems(i).Type = 1 Then
     Rectangle = f.Shapes(nomGroupe).GroupItems(i).Name
   End If
  Next i
End Function
Function ligne(f, nomGroupe)
  ligne = Range(f.Shapes(nomGroupe).TopLeftCell.Address).Row
End Function

Sub afficheNomsgroupe()
  For Each s In f.Shapes
    If s.Type = 6 Then
      Range(s.TopLeftCell.Address).Offset(-1) = s.Name
      Range(s.TopLeftCell.Address).Offset(-1).Interior.ColorIndex = xlNone
      Range(s.TopLeftCell.Address).Offset(-1).Font.ColorIndex = xlNone
    End If
  Next s
End Sub

Sub razCoul()
  For Each s In f.Shapes
    If s.Type = 6 Then
      If Me.ComboBox1 <> s.Name And Me.ComboBox2 <> s.Name Then
         Range(s.TopLeftCell.Address).Offset(-1).Font.ColorIndex = vbBlack
      End If
    End If
  Next s
End Sub

JB

 

[xhudi69]

Re : SHAPE oh! my SHAPE

Bonjour BOISGONTIER, le Forum,

Je suis sur vos traces mais vous avez toujours une longueur d'avance, par contre mes codes sont plus rustiques, j'en ai pour un petit moment à digérer tout cela.

C'est vraiement très sympa de vous être interresser à ce point pour ce fil
Il faut que je m'y remette, j'ai du boulot en perspective (Je suis encore à la modification de la bibliothèque)

Merci de tout coeur.

@+