Fonction VBA pour dessiner un drapeau écossais

Pino12 · 12 Septembre 2015

Bonjour le forum,

Je dois dessiner un drapeau écossais à l'aide d'une fonction pour mon cours de VBA. Seulement cela implique de créer des diagonales et de colorier uniquement la moitié d'une cellule. Après avoir chercher sur internet je n'ai toujours pas trouver de solution

Si quelqu'un à une idée sur le fonctionnement d'une telle fonction, je suis preneur !

Merci d'avance

Pino12 · 12 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Merci beaucoup Pierre !

Tu pourrais m'expliquer cette phrase s'il te plait ? Je comprends bien le reste de la macro sinon
For Each sh In ActiveSheet.Shapes
sh.Delete

Pino12 · 12 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Ok je comprends mieux !

Une dernière question, pour aligner parfaitement les triangles isocèles entre eux tu l'as fait à la main ?

BOISGONTIER · 12 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Bonsoir,

Pour créer un drapeau Français/Italien dans une cellule ou un champ
Si un texte est déjà présent dans la cellule ou le champ, il apparaît par transparence.

=drapeauFR(Champ;Transparence)
=drapeauIT(Champ;Transparence)

http://boisgontierjacques.free.fr/fichiers/Images/ConstructeurDrapeau.xls

JB

job75 · 13 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Bonjour Pino12, tatiak, JB,

Voyez le fichier joint et cette macro :

Code:

Sub DrapeauEcossais(cel As Range)
Dim x, y, w, h, e

With cel
  x = .Left: y = .Top
  w = .Width: h = .Height
  e = Application.Min(w, h) / 8 'coefficient à adapter
End With

ActiveSheet.DrawingObjects.Delete

ActiveSheet.Shapes.AddShape msoShapeIsoscelesTriangle, x + e, y + h / 2 + e, w - 2 * e, h / 2 - e

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x + e, y, w - 2 * e, h / 2 - e)
  .Rotation = 180
End With

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 0, 0, 0, 0)
  .Rotation = 90
  .Left = x + w / 2 - e: .Top = y + e
  .Width = h - 2 * e: .Height = w / 2 - e
End With

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 0, 0, 0, 0)
  .Rotation = -90
  .Left = x + w / 2 + e: .Top = y + h - e
  .Width = h - 2 * e: .Height = w / 2 - e
End With

End Sub

A+

job75 · 13 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Re,

Si l'on veut définir la couleur il suffit d'ajouter un argument à la macro :

Code:

Sub DrapeauEcossais(cel As Range, couleur As Range)
Dim x, y, w, h, e

With cel
  x = .Left: y = .Top
  w = .Width: h = .Height
  e = Application.Min(w, h) / 8 'coefficient à adapter
End With

ActiveSheet.DrawingObjects.Delete

ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x + e, y + h / 2 + e, w - 2 * e, h / 2 - e) _
  .Fill.ForeColor.RGB = couleur.Interior.Color

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x + e, y, w - 2 * e, h / 2 - e)
  .Rotation = 180
  .Fill.ForeColor.RGB = couleur.Interior.Color
End With

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 0, 0, 0, 0)
  .Rotation = 90
  .Left = x + w / 2 - e: .Top = y + e
  .Width = h - 2 * e: .Height = w / 2 - e
  .Fill.ForeColor.RGB = couleur.Interior.Color
End With

With ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 0, 0, 0, 0)
  .Rotation = -90
  .Left = x + w / 2 + e: .Top = y + h - e
  .Width = h - 2 * e: .Height = w / 2 - e
  .Fill.ForeColor.RGB = couleur.Interior.Color
End With

End Sub

Fichier (2).

A+

Efgé · 14 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Bonjour

Ne réponds pas à la question, mais pourra être utile si il y a un "cours de graph"

Cordialement

Edit: Fichier plus optimisé

Pino12 · 18 Septembre 2015

Re : Fonction VBA pour dessiner un drapeau écossais

Merci à tous avec un peu de retard ! J'avais choisi la solution de Titiak avant de me présenter ce travail en cours

Fonction VBA pour dessiner un drapeau écossais

Pino12

XLDnaute Junior

Pino12

XLDnaute Junior

Pino12

XLDnaute Junior

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Efgé

XLDnaute Barbatruc

Pièces jointes

Pino12

XLDnaute Junior

Discussions similaires