Les images et shapes

Accueil

Insertion d'une image
Positionnement
Adresse Cellule Shape
Visibilite
Creation Shape
Suppression
Types de shapes
Ecriture dans un shape
Création info-bulles pour shapes au survol
Récupération texte de shapes
Affectation d'une macro à un shape
Image arrière plan
Impression avec image arrière-plan
Affichage cellule dans zone de texte
Appareil Photo
Groupage Shapes
Choix d'une image interne avec formule
Image conditionnelle avec formule
Choix d'une image interne avec VBA
Choix de plusieurs images internes
Fonction d'affichage image interne
Choix d'une image externe
Choix de plusieurs images externes
Fonction d'affichage d'une image externe
Import d'images
Export image interne
Export d'un champ vers fichier Gif
Transforme un graphe en image
Export d'un graphe en Gif

-Choix d'une photo avec une formule
-Image conditionnelle
-Planning
-Défilement de texte
-Clignotement d'un shape
-Message d'attente
-Copie un champ dans un formulaire
-Visualisation d'un champ au survol d'une cellule
-Affichage du contenu d'une cellule au survol
-Chronomètre
-Loupe cellule
-Zoom champ au survol du champ
-Générique
-Compter images champ
-Modifier forme commentaire
-Commentaires avec triangle vert
-Curseur rouge
-Curseur horizontal
-Photo en commentaire
-Affichage d'un champ dans une image de formulaire
-TrombinoscopeBD
-Visualisation d'une fiche dans un shape
-Création d'un organigramme dynamique à partir d'une BD
-Création organigramme hiérarchique shapes à partir d'une BD
-Généalogie avec shapes
-Nomenclature avec shapes
-Carte de France
-Survol de la souris
-Affichage d'une image externe dans un formulaire
-Recherche image externe par mot clé
-Survol d'une image
-Diaporama photos
-Diaporama de tableaux
-Affichage d'une image interne dans un formulaire
-Affichage image interne dans un cadre
-Fonction d'affichage d'une image interne
-Affiche une photo externe au survol d'une cellule
-Arrière plan tableau avec shape transparent
-Jauge
-
Modification de la transparence de shapes par une fonction
-Fonction d'affichage d'une image d'arrière-plan sur un champ
-Noms de champ dans shapes
-Choix du champ à visualiser
-Déplacement d'un shape avec le curseur
-Conversion de photos commentaires en JPG
-Conversion de photos commentaires en images internes
-Conversion d'images internes en JPG
-Choix d'une photo interne dans un listBox photo
-Choix d'une photo externe dans un ListBox photo
-Copie les images dans l'onglet associé
-Filtre de shapes
-Création de flèches pour données/validation/liste
-Construction de flèches
-Construction de feux tricolores
-Classement avec images
-Inverse gras/maigre
-Filtre lettre
-Nom de l'image d'une cellule
-Création de shapes boutons
-Fonction CouleurImage()
-Fonction de coloriage d'un shape
-Coloriage d'indicateurs
-Fonction d'affichage d'un libellé sur un shape
-Affichage d'un texte sur une photo
-Colorier un shape avec la couleur d'une cellule
-Carte de France des départements et des régions
-Colorier carte Europe
-Colorier Carte Monde
-Affichage d'un commentaire au survol d'une image
-Survol d'un shape
-Fonction drapeau Français

 

 

Insertion d'une image externe

Pictures.Insert(fichierImage) insère le fichier spécifié à la position du curseur.

Sub essai()
  répertoirePhoto = "c:\mesdoc\" ' Adapter
  nom = "droc"
  ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg").Name = nom
  ActiveSheet.Shapes(nom).Left = [B2].Left
  ActiveSheet.Shapes(nom).Top = [B2].Top
End Sub

ou

Sub essai2()
  répertoirePhoto = "c:\mesdoc\" ' Adapter
  nom = "droc"
  Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg")
  img.Left = [B2].Left
  img.Top = [B2].Top
  img.Name = nom
End Sub

Pour que la hauteur de l'image soit égale à la hauteur de la cellule

répertoirePhoto = "c:\mesdoc\" ' Adapter
nom = "droc"
Set c = Range("B2")
With ActiveSheet
.Pictures.Insert(répertoirePhoto & nom & ".jpg").Name = nom
.Shapes(nom).Left = c.Left
.Shapes(nom).Top = c.Top
.Shapes(nom).LockAspectRatio = msoTrue
.Shapes(nom).Height = c.Height
End With

Pour que l'image occupe la cellule en hauteur et largeur

répertoirePhoto = "c:\mesdoc\" ' Adapter
nom = "droc"
Set c = Range("B2")
With ActiveSheet
.Pictures.Insert(répertoirePhoto & nom & ".jpg").Name = nom
.Shapes(nom).Left = c.Left
.Shapes(nom).Top = c.Top
.Shapes(nom).LockAspectRatio = msoFalse
.Shapes(nom).Height = c.Height
.Shapes(nom).Width = c.Width
End With

Si la cellule est fusionnée

répertoirePhoto = "c:\mesdoc\" ' Adapter
nom = "droc"
Set c = Range("B2").MergeArea
With ActiveSheet
.Pictures.Insert(répertoirePhosto & nom & ".jpg").Name = nom
.Shapes(nom).Left = c.Left
.Shapes(nom).Top = c.Top
.Shapes(nom).LockAspectRatio = msoFalse
.Shapes(nom).Height = c.Height
.Shapes(nom).Width = c.Width
End With

Import avec GetOpenFilename

GetOpenFileName

Sub ImportImage()
  Image = Application.GetOpenFilename("Fichiers Gif ou Jpg ,*.gif;*.jpg")
  If Image <> False Then
    a = Split(Image, "\")
    nomimage = a(UBound(a))
    Set c = ActiveCell
    With ActiveSheet
      .Pictures.Insert(Image).Name = nomimage
      .Shapes(nomimage).Height = c.Height
      .Shapes(nomimage).Left = c.Left + (c.Width - .Shapes(nomimage).Width) / 2
      .Shapes(nomimage).Top = c.Top
      .Shapes(nomimage).LockAspectRatio = msoTrue
    End With
  End If
End Sub

Gif Web

Set img=ActiveSheet.Pictures.Insert ("http://www.lemonde.fr/medias/www/1.2.167/img/lgo/lemonde_fr_grd.gif")

Import images Web

Importe les images associées aux hyperliens

Import Images Web

Sub ImportImagesLiens()
  sup
  For Each c In ActiveSheet.Hyperlinks
    If UCase(Right(c.Address, 4)) = ".GIF" _
      Or UCase(Right(c.Address, 4)) = ".PNG" _
        Or UCase(Right(c.Address, 4)) = ".JPG" Then
      On Error Resume Next
      Set img = ActiveSheet.Pictures.Insert(c.Address)
      If Err = 0 Then
        img.Left = c.Parent.Offset(, 1).Left
        img.Top = c.Parent.Top
        c.Parent.EntireRow.RowHeight = img.Height
        img.Name = c.TextToDisplay
        ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(img.Name), Address:=c.Address
      End If
      On Error GoTo 0
    End If
   Next c
   bulles
End Sub

Sub sup()
   For Each s In ActiveSheet.Shapes
     If s.Type = 11 Then s.Delete
   Next s
End Sub

Sub bulles()
  For Each s In ActiveSheet.Shapes
    If s.Type = 11 Then s.Hyperlink.ScreenTip = s.Name
  Next s
End Sub

Image Web dans un formulaire

FormImageWeb

Private Sub UserForm_Initialize()
  Set f = Sheets("feuil1")
  s = "https://www.google.fr/images/srpr/logo11w.png"
  Set img = ActiveSheet.Pictures.Insert(s)
  img.Left = 1
  img.Top = 1
  img.CopyPicture
  f.ChartObjects.Add(0, 0, img.Width, img.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
  img.Delete
End Sub

Choix d'une photo dans un contrôle image

Choix Image Contôle

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" Then
     répertoirePhoto = "c:\mesdoc" 'adapter
     Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")
   End If
End Sub

Positionnement d'un shape

Les propriétés Left et Top définissent la position d'un shape.

ActiveSheet.Shapes(1).Top =100
ActiveSheet.Shapes(1).Left =100

Positionnement d'un shape sur une cellule

Sub Positionnement()
  ActiveSheet.Shapes(1).Top = [B10].Top
  ActiveSheet.Shapes(1).Left = [B10].Left
End Sub

Centrage d'une image dans un champ

Sub CentrageChamp()
  Set champ = Range("B2:F12")
  Set img = ActiveSheet.Shapes(1)
  img.Top = champ.Top + champ.Height / 2 - img.Height / 2
  img.Left = champ.Left + champ.Width / 2 - img.Width / 2
End Sub

Centrage image

Adresse de la cellule d'un shape

TopLeftCell.Address
BottomRightCell.Address

Sur cet exemple, nous supprimons le shape de la cellule B10

Sub EffaceMentShapeCellule()
   For Each s In ActiveSheet.Shapes
    If s.TopLeftCell.Address = "$B$10" Then
      s.Delete
    End If
   Next s
End Sub

Cellules contenant des images

For Each s In ActiveSheet.Shapes
  x= s.TopLeftCell.Address
  y= s.BottomRightCell.Address
Next s

Sélectionne la cellule où est situé un shape

SelectCelluleShape

Set s = ActiveSheet.Shapes(Application.Caller).TopLeftCell
Cells(s.Row, s.Column).Select

Visibilité

Shapes("Monshape").Visible = True

ShapeAfficheCache

Sub VisualiseShapes()
  For Each s In ActiveSheet.Shapes
    If UCase(Left(s.Name, 1)) = "X" Then s.Visible = True
  Next s
End Sub

Sub CacheShapes()
  For Each s In ActiveSheet.Shapes
    If UCase(Left(s.Name, 1)) = "X" Then s.Visible = False
  Next s
End Sub

Affichage d'une cellule dans une zone de texte

Dans la barre de formule:

=$B$8

CelluleZoneTexte

Création Shape

AddTextbox(Orientation,gauche, haut, largeur, hauteur)

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50).Select
Selection.Font.Name = "Verdana"
Selection.Font.Size = 13
Selection.Name = "monshape"

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50).TextFrame.Characters.Text = "Texte"

Sub essai()
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50).Name = "monshape"
  With ActiveSheet.Shapes("monshape")
    .TextFrame.Characters.Text = "ceci est un essai"
    .TextFrame.Characters(Start:=1, Length:=4).Font.ColorIndex = 3
    .Fill.ForeColor.RGB = RGB(255, 255, 0)
    .TextFrame.Characters.Font.Size = 8
    .TextFrame.Characters(Start:=12, Length:=6).Font.Name = "Comic Sans Ms"
    .TextFrame.Characters(Start:=12, Length:=6).Font.Size = 12
   End With
End Sub

Ecriture dans un shape

ActiveSheet.Shapes("monshape").TextFrame.Characters.Text = "ceci est un essai"
ActiveSheet.Shapes("monshape").DrawingObject.Font.ColorIndex = 3
ActiveSheet.Shapes("monshape").OLEFormat.Object.Font.ColorIndex = 4

Couleur écriture

ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.ColorIndex = 3

Couleur fond

Selection.ShapeRange.Fill.ForeColor.SchemeColor =13

Gras

ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.Bold = True

Autre écriture

ActiveSheet.Shapes("monshape").DrawingObject.Caption = "xxxxx"

Pour lire le texte d'un shape

temp = ActiveSheet.Shapes("monshape").DrawingObject.Caption
temp = ActiveSheet.Shapes("monshape").TextFrame.Characters.Text

Pour lire le texte de tous les shapes d'un onglet

Sub LireTexteShapes()
  For Each s In ActiveSheet.Shapes
    i = i + 1
    Cells(i, 1) = s.Name
    Cells(i, 2) = TexteShape(s)
  Next s
End Sub

Function TexteShape(s)
  TexteShape = s.TextFrame.Characters.Text
End Function

Pour lire le texte d'un shape à partir du tableur

=TexteTableur("monshape")

Function TexteShapeTableur(s)
  Set f = Sheets(Application.Caller.Parent.Name)
  TexteShapeTableur = f.Shapes(s).TextFrame.Characters.Text
End Function

Renommer les shapes d'un onglet

Sub renommeShapes()
  i = 0
  For Each s In ActiveSheet.Shapes
    If s.Type <> 8 And s.Type <> 13 Then
      i = i + 1
      s.Name = "TextBox" & i
    End If
  Next s
End Sub

Recherche intuitive zone de texte

Autre forme d'écriture dans un shape

With ActiveSheet.Shapes("FR-175").TextFrame2.TextRange
  .Characters.Text = "75"
  .Parent.VerticalAnchor = msoAnchorMiddle
  .Parent.HorizontalAnchor = msoAnchorCenter
End With

VerticalAnchor=msoAnchorTop ou msoAnchorBottom ou msoAnchorMiddle
HorizontalAnchor=msoAnchorCenter ou msoAnchorNone

Ecrit Shape Forme Libre

Sub essaiCentré()
  ecritShapeCentre "orne", "Orne"
  ecritShapeCentre "sarthe", "Sarthe"
  ecritShapeCentre "triangle", "abcd"
 ecritShapeCentre "test", "Coucou"
End Sub

Sub essaiPosition()
  ecritShapePosition "orne", "Orne", 15, 4
  ecritShapePosition "sarthe", "Sarthe", 13, 4
  ecritShapePosition "triangle", "abcd", 20, 20
  ecritShapePosition "test", "Coucou", 50, 50
End Sub

Sub ecritShapeCentre(nomShape, Libellé)
With ActiveSheet.Shapes(nomShape).TextFrame2
.TextRange.Characters.Text = Libellé
.TextRange.Characters.Font.Size = 8
.MarginLeft = 0
.MarginTop = 0
.MarginBottom = 0
.MarginRight = 0
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
End With
ActiveSheet.Shapes(nomShape).OLEFormat.Object.Font.Color = vbBlack
End Sub

Sub ecritShapePosition(nomShape, Libellé, gauche, haut)
With ActiveSheet.Shapes(nomShape).TextFrame2
.TextRange.Characters.Text = Libellé
.TextRange.Characters.Font.Size = 8
.MarginLeft = gauche
.MarginTop = haut
.MarginBottom = 0
.MarginRight = 0
End With
End Sub

AddLine(débutX,débutY,finX,finY)

ActiveSheet.Shapes.AddLine(10, 10, 100, 100).Line.ForeColor.RGB = RGB(255, 0, 0)

ActiveSheet.Shapes.AddLine(10, 10, 100, 100).name="xxx"
ActiveSheet.Shapes("xxx").Line.ForeColor.RGB = RGB(255, 0, 0)

AddShape(Type, gauche, haut, largeur, hauteur)

ActiveSheet.Shapes.AddShape(msoShapeOval, 10, 10, 60, 50).Name = "MonShape"
ActiveSheet.Shapes("MonShape").TextFrame.Characters.Text = "Texte dans un shape"
ActiveSheet.Shapes("MonShape").Fill.ForeColor.SchemeColor = 13

ou

ActiveSheet.Shapes.AddShape(msoShapeOval, 10, 10, 60, 50).Name = "MonShape"
ActiveSheet.Shapes("MonShape").OLEFormat.Object.Interior.ColorIndex = 36
ActiveSheet.Shapes("MonShape").OLEFormat.Object.Characters.Text = "Texte dans un shape"

Exemple avec rectangle

Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 20)
With s
.TextFrame.Characters.Text = "Ceci est un essai"
.TextFrame.Characters.Font.Color = vbBlack
.Fill.ForeColor.RGB = vbYellow
End With
s.Name = "monshape"

Exemple avec rectangle arrondi

Sub CreeShapeCouleur()
  Set f = Sheets("feuil1")
  nomShape = "monshape"
  f.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, 60, 30).Name = nomShape
  f.Shapes(nomShape).Line.ForeColor.SchemeColor = 1
  txt1 = "Dupont"
  txt2 = "Directeur"
  txt = txt1 & vbLf & txt2
  With f.Shapes(nomShape)
   .TextFrame.Characters.Text = txt
   .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 9
   .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
   .TextFrame.Characters(Start:=1, Length:=Len(txt1)).Font.Bold = True
   .TextFrame.Characters(Start:=1, Length:=Len(txt1)).Font.ColorIndex = 3
   .Fill.ForeColor.RGB = vbYellow
  End With
End Sub

Formes shapes

Formes Shapes

Création de shapes avec hyperliens

Cree Shapes hyperliens

Sub CreeShape()
  Set s = Sheets(1).Shapes.AddShape(msoShapeOval, 50, 10, 100, 30)
  s.Name = "Menu1"
  With s
    .TextFrame.Characters.Text = " Feuil2"
    .TextFrame.Characters.Font.Color = vbWhite
    .Fill.ForeColor.RGB = vbRed
    .Line.ForeColor.RGB = vbWhite
  End With
  Sheets(1).Hyperlinks.Add Anchor:=s, Address:="", SubAddress:="Feuil2!A1"
End Sub

Sub CreeShape2()
  For i = 1 To 3
    Set s = Sheets(1).Shapes.AddShape(msoShapeOval, 50, 30 * i, 100, 25)
    With s
    .TextFrame.Characters.Text = " Feuil" & i + 1
    .TextFrame.Characters.Font.Color = vbWhite
    .Fill.ForeColor.RGB = vbRed
    .Line.ForeColor.RGB = vbWhite
   End With
   Sheets(1).Hyperlinks.Add Anchor:=s, Address:="", SubAddress:="Feuil" & i + 1 & "!A1"
  Next i
End Sub

Sub bulles()
  For Each s In ActiveSheet.Shapes
    If s.Type = 1 Then s.Hyperlink.ScreenTip = s.Name
  Next s
End Sub

AddTextEffect(PresetTextEffect, Text, FontName, FontSize, FontBold, FontItalic, Left, Top)

Crée un shape (Word Art)

result = InputBox("Texte?")
If result = "" Then End
ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, result & Chr(13) & "" & Chr(10) & "", _
"Arial Black", 36#, msoFalse, msoFalse, 25, 25).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 31

Suppression de shapes

Supprime le shape nommé Monshape

Sheets("planning").Shapes("Moshape").Delete

Efface tous les shapes d'une feuille

Sheets("planning").DrawingObjects.Delete

Efface les shapes d'un champ

Sub EffaceMentShapeChamp()
  For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$A$1:$D$20")) Is Nothing Then
       s.Delete
    End If
  Next s
End Sub

Efface les shapes de la cellule active

Sub EffaceMentShapeCelluleActive()
  For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ActiveCell) Is Nothing Then s.Delete
 Next s
End Sub

Efface les shapes sauf les boutons

Sub SupShapeSaufBoutons()
  For Each s In ActiveSheet.Shapes
    If s.Type <> 8 Then s.Delete
  Next s
End Sub

Colorie les shapes d'un champ

Sub ColoriageShapeChamp()
  For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$B$2:$D$12")) Is Nothing Then
      s.Fill.ForeColor.RGB = RGB(0, 255, 0)
    End If
  Next s
End Sub

Sélectionne les shapes d'un champ

Sub SélectionShapeChamp()
  For Each s In ActiveSheet.Shapes
   If Not Intersect(s.TopLeftCell, Range("$A$1:$D$20")) Is Nothing Then
      s.Select False
   End If
  Next s
End Sub

Donne le nombre de shapes d'un champ

Function NbshapesChamp(champ As Range)
  f = Application.Caller.Parent.Name
  For Each s In Sheets(f).Shapes
    If Not Intersect(s.TopLeftCell, champ) Is Nothing Then n = n + 1
  Next
  NbshapesChamp = n
End Function

N'efface pas les boutons

Sub EffaceShapesSaufBoutons()
   For Each i In ActiveSheet.Shapes
     If i.Type <> 8 And i.Type <> 12 Then
       ActiveSheet.Shapes(i.Name).Delete
     End If
   Next i
End Sub

Nommer les shapes de la colonne D avec les noms en colonne A

For Each s In ActiveSheet.Shapes
  If Not Intersect(s.TopLeftCell, Range("$D$1:$D$20")) Is Nothing Then
     s.Name = s.TopLeftCell.Offset(, -3)
  End If
Next s

Masquer les shapes à l'impression

For Each s In ActiveSheet.Shapes
  s.ControlFormat.PrintObject = False
Next s

Différents types de shapes

Sub shapestype()
  i = 2
  For Each s In ActiveSheet.Shapes
   Cells(i, 1) = s.Type
   Cells(i, 2) = s.Name
   i = i + 1
  Next s
End Sub

Récupération texte de shapes

RecupTexteShape

Sub RecupTexteShapes()
  ligne = 2
  For Each s In Sheets(1).Shapes
    Cells(ligne, 1) = s.Name
    Cells(ligne, 2) = s.TextFrame.Characters.Text
    Cells(ligne, 3) = s.TopLeftCell.Address
    Cells(ligne, 4) = s.Type
    ligne = ligne + 1
  Next s
End Sub

Créer des info-bulles pour les shapes au survol

A l'aide d'hyperliens, on crée des bulles qui s'affichent au survol de shapes.

Créer Bulles Images

Sub bulles()
  For Each s In ActiveSheet.Shapes
   If s.Type = 13 Or s.Type = 12 Then
     ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
     s.Hyperlink.ScreenTip = s.Name
   End If
  Next s
End Sub

Survol d'un bouton ActiveX

Sub HyperLienBoutonActiveX()
  Set s = ActiveSheet.Shapes(MonBouton")
  ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
  s.Hyperlink.ScreenTip = "coucou au survol"
End Sub

Autre exemple

Créer info-Bulles Images2

 

Sub bulles()
  For Each s In ActiveSheet.Shapes
   If s.Type <> 8 Then
     ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
     tmp = s.Name
     bulle = Application.VLookup(tmp, [légendes], 2, False)
     If Not IsError(bulle) Then
        s.Hyperlink.ScreenTip = bulle & Chr(10) & "...."
     Else
       s.Hyperlink.ScreenTip = "...."
     End If
   End If
 Next s
End Sub

Fonction renvoyant l'info-bulle d'un shape

Function InfoBulle(s)
  Set f = Sheets(Application.Caller.Parent.Name)
  InfoBulle = f.Shapes(s).Hyperlink.ScreenTip
End Function

Renommage de shapes et coloriage

Renomme les shapes avec le texte contenu dans les shapes.

ShapesColor

Sub Renomme()
  For Each s In ActiveSheet.Shapes
    If s.Type = 1 Then
      On Error Resume Next
      tmp = s.TextFrame.Characters.Text
      If Err = 0 Then
          s.Name = s.TextFrame.Characters.Text
      Else
         MsgBox "Erreur : " & s.Name
      End If
      On Error GoTo 0
    End If
  Next s
End Sub

Image arrière plan

Sub ArrierePlanTexte()
  repertoire = ActiveWorkbook.Path
  For Each s In ActiveSheet.Shapes
    s.Select
    Selection.ShapeRange.Fill.UserPicture repertoire & "\fond_nico.jpg"
  Next s
End Sub

Autre exemple

Set monshape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 100, 100, 100, 100)
monshape.Fill.UserPicture "c:\nikkosite\images\belier.jpg"

Affichage d'une cellule dans une zone de texte

Pour récupérer le contenu de la cellule B8 dans une zone de texte, frapper =$B$8 dans la barre de formule

Affectation d'une macro à un shape

Sub affecteMacroShape()
  Sheets("feuil1").Shapes("monshape").OnAction = "macro1"
End Sub

Sub macro1()
  nomShape = Application.Caller
  MsgBox nomShape
End Sub

Groupage de Shapes

Sub groupage2shapes()
  Set f = Sheets("feuil1")
  Dim a(1 To 2)
  NomShape1 = "France"
  Nomshape2 = "Corse"
  a(1) = NomShape1: a(2) = Nomshape2
  f.Shapes.Range(a).Group.Name = "FranceCorse"
  f.Shapes("FranceCorse").Fill.ForeColor.RGB = vbRed
End Sub

Sub degroupage()
  ActiveSheet.Shapes("FranceCorse").Ungroup
End Sub

Sub couleurFrance()
  ActiveSheet.Shapes("France").Fill.ForeColor.RGB = vbGreen
  ActiveSheet.Shapes("France").TextFrame2.TextRange.Characters.Text = "France"
End Sub

Groupage d'un shape et d'une photo

Sub groupageShapePhoto()
  Set f = Sheets("feuil1")
  Dim a(1 To 2)
  nomshape = "Zt1"
  nomphoto = "muffin"
  f.Shapes(nomphoto).Left = ActiveSheet.Shapes(nomshape).Left + 55
  f.Shapes(nomphoto).Top = ActiveSheet.Shapes(nomshape).Top + 10
  a(1) = nomshape: a(2) = nomphoto
  f.Shapes.Range(a).Group.Name = nomphoto & "G"
End Sub

Ci dessous, nous ajoutons un texte sous la photo

Sub GroupePhotoTexte()
  Set f = Sheets("bd")
  nomphoto = "Droc"
  f.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 50, 13).Name = nomphoto & "T"
  f.Shapes(nomphoto & "T").Line.ForeColor.SchemeColor = 22
  txt = nomphoto
  With f.Shapes(nomphoto & "T")
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
  End With
  f.Shapes(nomphoto & "T").Left = f.Shapes(nomphoto).Left
  f.Shapes(nomphoto & "T").Top = f.Shapes(nomphoto).Top + f.Shapes(nomphoto).Height
  Dim a(1 To 2)
  a(1) = nomphoto: a(2) = nomphoto & "T"
  f.Shapes.Range(a).Group.Name = nomphoto & "G"
End Sub

Affiche du texte sur des photos

TexteSurPhoto

Sub TexteShapePhoto()
  Set f = Sheets("feuil1")
  Dim a(1 To 2)
  For i = 1 To 2
   Set cel = f.Cells(i, 1)
   For Each s In f.Shapes
     If s.TopLeftCell.Address = cel.Address Then nomphoto = s.Name
  Next s
  f.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 26).Name = nomphoto & "_T"
  f.Shapes(nomphoto & "_T").Line.ForeColor.SchemeColor = 22
  With f.Shapes(nomphoto & "_T")
   .TextFrame.Characters.Text = cel.Value
   .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
   .Fill.Transparency = 1
   .Line.Visible = False
   .Left = cel.Left
   .Top = cel.Top + 10
   .Left = cel.Left + 10
  End With
  a(1) = nomphoto & "_T": a(2) = nomphoto
  f.Shapes.Range(a).Group.Name = nomphoto & "G"
 Next i
End Sub

Liste des items d'un groupe

Sub ListeItemsGroupe()
  For i = 1 To ActiveSheet.Shapes("zt2g").GroupItems.Count
    MsgBox ActiveSheet.Shapes("zt2g").GroupItems(i).Name
  Next i
End Sub

Connexion de 2 shapes

Sub connectionShapes()
  Set f = Sheets("feuil1")
  nomCnn = "Cnn"
  f.Shapes.AddConnector(msoConnectorElbow, 10, 10, 10, 10).Name = nomCnn
  f.Shapes(nomCnn).ConnectorFormat.BeginConnect f.Shapes("Droc"), 3
  f.Shapes(nomCnn).ConnectorFormat.EndConnect f.Shapes("Bouchez"), 1
End Sub

Connexion de 2 groupes

ConnexionGroupes

-Chaque groupe contient un rectangle
-La connexion se fait par les rectangles

Sub Connection2()
  Set f = Sheets("feuil1")
  groupe1 = "disjoncteur"
  groupe2 = "disjoncteur_diff"
  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
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

ConnexionGroupesForm

Appareil photo

Attribuer une image d'arrière-plan à un champ

-Photographier le champ avec l'appareil photo
(Affichage/Barre outils/Personnaliser/Commandes/Outils/Appareil photo
ou Edition/Copier Maj+Edition coller l'image avec liaison)
-Attribuer une image de fond à la photo avec
Clic-droit/Format de l'image/Couleurs et traits/Couleurs/Motifs et textures/Images

Impression avec image arriere-plan

On veut imprimer des bons avec un arrière plan. On photographie C3:D4 dans un autre onglet et on attribue
un arrière-plan au shape (Edition/Copier Maj+Edition coller l'image avec liaison).

LesBons

Visualiser un champ lors d'un clic sur une cellule

Visualise le champ A1:E6 de feuil2 dans un shape lié
Cliquer sur A1 pour voir le shape

-Utiliser l'appareil photo
(Affichage/Barre outils/Personnaliser/Commandes/Outils/Appareil photo)
.Sélectionner le champ puis cliquer sur l'appareil photo
ou
Edition/Copier Maj+Edition coller l'image avec liaison
.
-Nommer le shape MonShape

Shape appareil photo

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.Address = "$A$1" Then
      ActiveSheet.Shapes("monshape").Visible = True
   Else
      ActiveSheet.Shapes("monshape").Visible = False
   End If
End Sub

Visualisation d'un champ au survol d'une cellule

Visualise un champ au survol de la partie rouge de B2

Survol texte

-Utiliser l'appareil photo pour photographier le champ dans un shape
-Nommer ce shape Monca
-
Créer un label Label1 avec la BO contrôles

Dans le code de la feuille:

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
     ActiveSheet.Shapes("monca").Visible = False
  Else
     ActiveSheet.Shapes("monca").Visible = True
  End If
End Sub

Avec un caractère de la police Wingdings

Affichage du contenu d'une cellule au survol

SuvolCelluleChamp

Affichage d'une photo externe de la personne choisie en B2

Le nom de l'image est le même que le nom. Les images sont dans le répertoire du classeur Excel

ChoixImage

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("b2")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("B2") & ".jpg")
    img.Name = "monimage"
    img.Left = [B7].Left
    img.Top = [B7].Top
    Me.Shapes("Labulle").Visible = True
    Me.Shapes("Labulle").OLEFormat.Object.Text = "Je m'appelle " & [b2]
  End If
End Sub

La liste spécifiée dans Données/Validation en B2 est dynamique:

=DECALER($F$2;0;0;NBVAL($F:$F)-1)

Affiche une photo externe en fonction du nom

Le nom de l'image est différent du nom

ChoixImage

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, [B2]) Is Nothing Then
  répertoirePhoto = "c:\mesdoc\"
  On Error Resume Next
  ActiveSheet.Shapes("monimage").Delete
  p = Application.Match([B2], [Liste], 0)
  If Not IsError(p) Then
     NomImage = Range("Liste")(p).Offset(, 1)
     Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & NomImage)
     img.Name = "monimage"
     img.Left = [B5].Left
     img.Top = [B5].Top
   End If
   [B2].Select
 End If
End Sub

Affiche la photo externe associée au nom

Cliquer sur le nom pour faire apparaître la photo.

ChoixPhoto
ChoixPhoto5

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Range("A2:A5")) Is Nothing And Target.Count = 1 Then
    répertoirePhoto = "c:\mesdoc\" ' Adapter
    On Error Resume Next
    Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & Target & ".jpg")
    img.Name = "monimage"
    img.Left = Target.Offset(, 1).Left + 5
    img.Top = Target.Offset(, 1).Top
  End If
End Sub

Choix d'une image avec données/Validation

Images internes au classeur

Choix d'une photo interne

-Placer une photo dans la feuille en B4
-Créer les noms de champ avec Insertion/Nom/Définir
NomsImages =DECALER(Images!$B$3;;;;NBVAL(Images!$3:$3)-1)
ImageChoisie: =DECALER(Images!$B$5;;EQUIV(Choix!$B$3;NomsImages;0)-1)
-Cliquer sur l'image en B4
-Dans la barre de formule:=ImageChoisie

Affiche Photo3
Affiche Photo2
Affiche Photo1
Affiche 2 Photos
Affiche Photo
Affiche Photo Compteur
Liste Cascade Image

Remarque: Pour gérer plusieurs images, il faut créer un nom de champ ImageChoisiex pour chaque image.

Si les images sont dans des onglets nommés Droc,Fleury,...

ImageOnglet

-Placer une photo dans la feuille en A2
-Créer un nom de champ avec Insertion/Nom/Définir

  adr =INDIRECT(choix!$A$2&"!$a$1")

-
Cliquer sur l'image en A2
-Dans la barre de formule:=Adr

Si les images sont dans un autre classeur ouvert

C1 contient le nom du classeur
C4 contient le nom de l'onglet

Nom de champ
adr =INDIRECT("'["&$C$1&"]"&$C$4&"'!$A$1:$F38")

ImageOngletClasseur

Si le classeur est fermé

ImageOngletClasseur

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address = "$C$4" Then
   Application.ScreenUpdating = False
   chemin = ThisWorkbook.Path
   Workbooks.Open chemin & "\classeurImage.xls"
   ActiveWorkbook.Close
   Application.ScreenUpdating = True
  End If
End Sub

Image conditionnelle en fonction d'un résultat (en C7)

Image en fonction d'un résultat (en C7)

Image ConditionnelleInterne
Image ConditionnelleInterne2
Image ConditionnelleInterne 3
ImageConditionnelleExterne

-Créer 3 zones de texte ou images en J1,K1,L1
-Créer un nom de champ AdrImage:
=SI($C$7>100;$L$1;SI($C$7<50;$J$1;$K$1))
-En C1, sélectionner une IMAGE et dans la barre de formule: =Adrimage

Affichage d'une image en fonction des choix en D2 et D3

1-Créer un nom de champ Adr:

=SI(Feuil1!$D$2=Feuil1!$G$3;
SI(Feuil1!$D$3=Feuil1!$G$7;Feuil1!$I$20;Feuil1!$I$16);
SI(Feuil1!$D$3=Feuil1!$G$8;Feuil1!$I$28;Feuil1!$I$33))

2- Sélectionner l'image en B7
3- Dans la zone formule frapper =ADR et valider avec entrée

Image ConditionnelleInterne 2

Autre exemple

Affiche une image en fonction de la valeur en B8

Image ConditionnelleInterne 4

Choix d'une image interne avec VBA

Les noms des images correspondent aux noms des personnes.

DVChoixUneImageInterne

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    On Error GoTo 0
    If Target <> "" Then
      Sheets("Images").Shapes(Target).Copy
      Target.Offset(0, 2).Select
      ActiveSheet.Paste
      Selection.Name = "monImage"
      Selection.ShapeRange.Left = ActiveCell.Left
      Selection.ShapeRange.Top = ActiveCell.Top
      Target.Select
    End If
   End If
End Sub

Les images ne sont pas nommées

DVChoixUneImageInterne2

PPrivate Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  If Target.Address = "$A$2" And Target.Count = 1 Then
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    On Error GoTo 0
    If Target <> "" Then
      lig = [liste].Find(Target, LookAt:=xlWhole).Row
      col = [liste].Column + 1
      For Each s In Sheets("Images").Shapes
        If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
     Next s
     Target.Offset(0, 2).Select
     ActiveSheet.Paste
     Selection.Name = "monImage"
     Selection.ShapeRange.Left = ActiveCell.Left
     Selection.ShapeRange.Top = ActiveCell.Top
     Target.Select
   End If
  End If
End Sub

Plusieurs images internes

Les images de l'onglet Images sont nommées En cours,Attente,Fini.

DVImagesInternes
DVLogo
DVMétéo
DVChoixGroupeImages
DVChoixImagesGym

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 8 And Target.Count = 1 Then
  '-- suppression
  For Each s In ActiveSheet.Shapes
    If s.Type = 13 Then
      If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then
         s.Delete
      End If
    End If
   Next s
   '--
  If Target <> "" Then
    Sheets("Images").Shapes(Target).Copy
    Target.Offset(0, 1).Select
    ActiveSheet.Paste
    Selection.ShapeRange.Left = ActiveCell.Left + 7
    Selection.ShapeRange.Top = ActiveCell.Top + 5
     Target.Select
   End If
  End If
End Sub

Sur cet exemple, après avoir choisi une image dans une cellule, l'opérateur peut cliquer sur l'image déjà choisie pour modifier son choix. Le menu déroulant est ouvert automatiquement.

DVMétéo
DVMétéo2
FormMétéo
Image en fonction d'un intervalle
Image en fonction d'un intervalle2

Private Sub Worksheet_Change(ByVal Target As Range)
  Set images = Sheets("logos")
  If Target.Column = 2 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
      End If
    End If
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 2 And Target.Count = 1 Then
     If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
       SendKeys "%{down}"
     End If
  End If
End Sub

Sub ClicImage()
  Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Select
  SendKeys "%{down}"
End Sub

Les images de l'onglet Images n'ont pas besoin d'être nommées

ChoixImage
ChoixImage1
ChoixImage2
Image en fonction d'une différence

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 2 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
       If s.Type = 6 Or s.Type = 9 Then
          If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then
             s.Delete
          End If
       End If
     Next s
     '--
     If Target <> "" Then
        lig = [liste].Find(Target, LookAt:=xlWhole).Row
        col = [liste].Column + 1
        For Each s In Sheets("Images").Shapes
          If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
        Next s
        Target.Offset(0, 1).Select
        ActiveSheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left + 7
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Target.Select
      End If
    End If
End Sub

Classement avec images

Les images sont déplacées en fonction du classement.

ClassementAvecImages

Private Sub Worksheet_Calculate()
  Application.ScreenUpdating = False
  ActiveSheet.Unprotect Password:=""
  For Each cel In [g2:g6]
   '-- suppression
   For Each s In ActiveSheet.Shapes
     If s.Type = 1 Or s.Type = 9 Then
       If s.TopLeftCell.Address = cel.Offset(, -1).Address Then s.Delete
     End If
  Next s
  '--
 If cel <> "" Then
   lig = [liste].Find(cel, LookAt:=xlWhole).Row
   col = [liste].Column + 1
   For Each s In Sheets("Images").Shapes
     If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
   Next s
   cel.Offset(, -1).Select
   ActiveSheet.Paste
   Selection.ShapeRange.Left = ActiveCell.Left + 3
   Selection.ShapeRange.Top = ActiveCell.Top
  End If
 Next cel
 'ActiveSheet.Protect Password:=""
End Sub

Affichage d'un shape transparent

2 shapes transparents (70%) sont nommés Plus et Moins.

A la saisie du % de réalisation en colonne C, le programme affiche dans la cellule de saisie le shape Plus si le % est >=95% et Moins si <95%.

RecapTableauBord

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect([C2:C1000], Target) Is Nothing And Target.Count = 1 Then
   For Each s In ActiveSheet.Shapes
     If s.Type = 1 Then
       If s.TopLeftCell.Address = Target.Address Then s.Delete
     End If
  Next s
  If Target <> "" Then
    If IsNumeric(Target) Then
      nomShape = IIf(Target >= 0.95, "plus", "moins")
      ActiveSheet.Shapes(nomShape).Copy
      Target.Select
      ActiveSheet.Paste
      Selection.Name = "Image" & ActiveCell.Row
      Selection.OnAction = "ClicImage"
      Selection.ShapeRange.Left = ActiveCell.Left + 20
      Selection.ShapeRange.Top = ActiveCell.Top + 5
      Target.Select
     End If
   End If
 End If
End Sub

Sub ClicImage()
  Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Select
End Sub

Image en fonction d'une valeur 1,2,3,...

ChoixImage

Private Sub Worksheet_Change(ByVal Target As Range)
  Set images = Sheets("images")
  If Target.Column = 2 And Target.Count = 1 Then
  '-- suppression
  For Each s In ActiveSheet.Shapes
    If s.Type = 5 Or s.Type = 6 Then
      If s.TopLeftCell.Address = Target.Address Then s.Delete
    End If
   Next s
   '--
   If Target <> "" Then
     On Error Resume Next
     col = Target + [liste].Column - 1
     lig = [liste].Row + 1
     For Each s In images.Shapes
       If s.TopLeftCell.Address = Cells(lig, col).Address Then
         s.Copy
         largeurImage = s.Width
         HauteurImage = s.Height
       End If
     Next s
     If Err = 0 Then
       Target.Select
       ActiveSheet.Paste
       Selection.ShapeRange.Left = Target.Left + Target.Width / 2 - largeurImage / 2
       Selection.ShapeRange.Top = Target.Top + 5
       Rows(Target.Row).RowHeight = HauteurImage + 10
     End If
    End If
  End If
End Sub

Affiche des étoiles en fonction de la note attribuée

Note étoile

Choix successifs d'images

ChoixSuccessifsImages

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address = "$C$2" And Target.Count = 1 Then
   Application.EnableEvents = False
   p = InStr(Target.Offset(0, -1), Target.Value)
   If p > 0 Then
     Target.Offset(0, -1) = Left(Target.Offset(0, -1), p - 1) & _
     Mid(Target.Offset(0, -1), p + Len(Target.Value) + 1)
     If Right(Target.Offset(0, -1), 1) = ":" Then
       Target.Offset(0, -1) = Left(Target.Offset(0, -1), Len(Target.Offset(0, -1)) - 1)
     End If
   Else
     If Target.Offset(0, -1) = "" Then
       Target.Offset(0, -1) = Target
     Else
       Target.Offset(0, -1) = Target.Offset(0, -1) & ":" & Target.Value
     End If
   End If
   Target.Value = Target.Offset(0, -1)
   '--- Images
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then s.Delete
    Next s
    a = Split(Target, ":")
    For i = LBound(a) To UBound(a)
    col = [liste].Find(a(i), LookAt:=xlWhole).Column
    lig = [liste].Row + 1
    For Each s In Sheets("Images").Shapes
      If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
    Next s
    Target.Offset(0, i + 2).Select
    ActiveSheet.Paste
    Selection.ShapeRange.Left = ActiveCell.Left + 7
    Selection.ShapeRange.Top = ActiveCell.Top + 5
    Target.Select
   Next i
   Application.EnableEvents = True
  End If
End Sub

Récupération d'un champ dans un commentaire

RecupChampComment
RecupImageInterneComment

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 4 Then
    répertoire = ThisWorkbook.Path
    lig = [liste].Find(Target, LookAt:=xlWhole).Row
    col = [liste].Column + 1
    Cells(lig, col).CopyPicture
    x = Cells(lig, col).Width
    y = Cells(lig, col).Height
    ActiveSheet.Paste Destination:=Range("A1") 'crée un shape
    Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    s.Copy
    With ActiveSheet
      .ChartObjects.Add(0, 0, s.Width, s.Height * 1.15).Chart.Paste
      .ChartObjects(1).Border.LineStyle = 0
      .ChartObjects(1).Chart.Export Filename:=répertoire & "\monimage.gif", FilterName:="gif"
      .Shapes(ActiveSheet.Shapes.Count).Delete
      .Shapes(ActiveSheet.Shapes.Count).Delete
    End With
    Target.Comment.Delete
    Target.AddComment
    Target.Comment.Shape.Fill.UserPicture répertoire & "\monimage.gif"
    Target.Comment.Shape.Height = y
    Target.Comment.Shape.Width = x
   End If
End Sub

Fonction affichage/masquage d'une image interne

On affiche une flèche dès que les cellules C2:C4 sont remplies

=afficheimage("lafleche";NBVAL(C2:C4)=3)

AfficheImage

Function afficheImage(s, ok)
  Set f = Sheets(Application.Caller.Parent.Name)
  f.Shapes(s).Visible = ok
End Function

On affiche une image dès que la cellule B6 dépasse la valeur 100.

La cellule B6 contient une formule (Somme(B2:B5).
Une fonction personnalisée AfficheCache(c;seuil;image) teste si B6 atteint 100 et affiche une image nommée Gidel sur l'exemple.

FonctionAfficheShape

Function AfficheCache(c, seuil, image)
  If c> seuil Then
     ActiveSheet.Shapes(image).Visible = True
  Else
     ActiveSheet.Shapes(image).Visible = False
  End If
  afffichecache = 0
End Function

Autre exemple

Affiche une image ou une autre suivant que le solde en C2 est positif ou négatif.

En D2: =affichecache(C2)

ImageSolde

Function AfficheCache(montant)
  If montant > 0 Then
    ActiveSheet.Shapes("Monte").Visible = True
    ActiveSheet.Shapes("Descend").Visible = False
  Else
    ActiveSheet.Shapes("Monte").Visible = False
    ActiveSheet.Shapes("Descend").Visible = True
  End If
  afffichecache = 0
End Function

Autre exemple

En A2, une formule donne comme résultat: Oui,Non,Peut-être.
On modifie les propriétés d'une image par une fonction =affichecache(A2;"monimage")
Cette fonction peut être utilisée pour gérer plusieurs images.

Function AfficheCache(c, image)
  Application.Volatile
  If c = "oui" Then
    ActiveSheet.Shapes(image).Visible = True
    ActiveSheet.Shapes(image).Line.ForeColor.SchemeColor = 12
  Else
    If c = "peut-etre" Then
       ActiveSheet.Shapes(image).Visible = True
       ActiveSheet.Shapes(image).Line.ForeColor.SchemeColor = 11
    Else
       ActiveSheet.Shapes(image).Visible = False
    End If
  End If
  AfficheCache = 0
End Function

AfficheCache2

Autre exemple

Affiche/cache le fond d'une image

Function AfficheFondImage(image, n)
  Application.Volatile
  ActiveSheet.Shapes(image).Fill.Visible = (n > 0)
  AfficheFondImage = 0
End Function

Modifie la couleur d'une flèche

FonctionCouleurFlèche

Function CouleurFleche(cel, NomFleche)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  If cel > 60 Then cel = 60
  temp = cel \ 20
  f.Shapes(NomFleche).Line.ForeColor.SchemeColor = Array(57, 4, 52, 2)(temp)
  CouleurFleche = 0
End Function

Images externes au classeur

Choix d'une seule image externe

Les noms des images correspondent aux noms des personnes.

ChoixImage
ChoixImage2
ChoixImage3

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
    On Error Resume Next
    Shapes("MonImage").Delete
    RépertoirePhoto = "c:\mesdoc\" ' adapter
    nf = RépertoirePhoto & "\" & Target & ".jpg"
    If Dir(nf) <> "" Then
      Set img = ActiveSheet.Pictures.Insert(nf)
      img.Name = "MonImage"
      img.Left = [A5].Left
      img.Top = [B5].Top
    End If
  End If
End Sub

Import dans un contrôle de Boîte à outils Contrôles

-Créer un contrôle image avec la Boîte à outils Contrôles

ChoixImage

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
    RépertoirePhoto = "c:\mesdoc\"     ' adapter
    nf = RépertoirePhoto & "\" & Target & ".jpg"
    If Dir(nf) <> "" Then
      Me.Image1.Picture = LoadPicture(nf)
      Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
    Else
      Me.Image1.Picture = Nothing
    End If
  End If
End Sub

Sur cette version, les dimensions du contrôle sont celles de la taille réelle de l'image.

ChoixImage

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
    RépertoirePhoto = "c:\mesdoc\" ' adapter
    nf = RépertoirePhoto & "\" & Target & ".jpg"
    If Dir(nf) <> "" Then
      taille = TaillePixelsImage(RépertoirePhoto, Target & ".jpg")
      Me.Image1.Height = Val(Split(taille, "x")(1))
      Me.Image1.Width = Val(Split(taille, "x")(0))
      Me.Image1.Picture = LoadPicture(nf)
      'Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
      Me.Image1.PictureSizeMode = fmPictureSizeModeClip
    Else
      Me.Image1.Picture = Nothing
    End If
  End If
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Ci dessous, les noms des images du répertoire sont placés en colonne G à l'ouverture du fichier.
La hauteur de l'image est modifiée (150) mais le rapport Hauteur/Largeur respecté.

AlbumPhoto4
AlbumPhoto2

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$1" And Target.Count = 1 Then
    On Error Resume Next
    Shapes("MonImage").Delete
    On Error GoTo 0
    rep = ThisWorkbook.Path ' A adapter
    nf = rep & "\" & Target
    Target.Offset(2, 0).Select
    Set image = ActiveSheet.Pictures.Insert(nf)
    image.Name = "MonImage"
    Shapes("monimage").Height = 150 ' On impose la hauteur
    Target.Select
  End If
End Sub

Sub auto_open()       ' Noms des images du répertoire
   [G2:G10000].ClearContents
   rep = ThisWorkbook.Path         ' A adapter
   nf = Dir(rep & "\*.jpg")
   i = 2
   Do While nf <> ""
     Sheets(1).Cells(i, "G") = nf
     i = i + 1
     nf = Dir
   Loop
   [G:G].Sort Key1:=[G2], Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False
End Sub

Choix de plusieurs images externes

DVImagesExternes

Private Sub Worksheet_Change(ByVal Target As Range)
  '-- suppression de l'image actuelle
  If Target.Column = 1 And Target.Count = 1 Then
     For Each s In ActiveSheet.Shapes
       If s.Type = 13 Then
          If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then s.Delete
       End If
     Next s
     RépertoirePhotos = ThisWorkbook.Path & "\" ' adapter
     On Error Resume Next
     Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & Target & ".jpg")
     If Err > 0 Then
       MsgBox "inconnu"
     Else
       img.Left = Target.Offset(, 1).Left + 15
       img.Top = Target.Offset(, 1).Top
     End If
   End If
End Sub

Choix de photos externes dans un listview

Choix Photo ListstView

Import d’images d’un répertoire

Importe les images d'un répertoire. On suppose que les images .jpg sont dans le répertoire c:\mesdoc\.

ImportImages

Sub ImportImages()
  ActiveSheet.DrawingObjects.Delete
  répertoirePhoto = "c:\mesdoc\"
  nf = Dir(répertoirePhoto & "*.jpg") ' premier fichier
  Range("b2").Select
  Do While nf <> ""
    Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & nf)
    img.Top = ActiveCell.Top
    img.Left = ActiveCell.Left
    img.Name = Left(nf, Len(nf) - 4) ' Donne un nom à l'image
    ActiveCell.Offset(0, -1) = Application.Proper(Left(nf, Len(nf) - 4))
    ActiveCell.EntireRow.RowHeight = img.Height + 2
    nf = Dir ' suivant
    ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Les noms des images à importer sont dans la colonne A

On suppose que les images .jpg sont dans le répertoire c:\mesdoc\

ImportImages

Sub ImportImages()
  répertoirePhoto = "c:\mesdoc\"
  suppression
  For Each c In [A2:A6]
    nf = répertoirePhoto & c & ".jpg"
    If Dir(nf) <> "" Then
      Set img = ActiveSheet.Pictures.Insert(nf)
      img.Left = c.Offset(, 1).Left
      img.Top = c.Offset(, 1).Top
      c.EntireRow.RowHeight = img.Height
    End If
  Next
End Sub

Sub suppression()
   For Each i In ActiveSheet.Shapes
      If i.Type = 13 Then i.Delete
   Next i
End Sub

Insertion d'images par bloc de 3

ImportImagesBloc

Cas1:On adapte la hauteur et la largeur des cellules à la photo

Sub InsereImagesBloc()
  suppression
  rep = "c:\mesdoc\" ' adapter
  NbImagesLigne = 3 ' adapter
  lig = 3
  col = 1
  nf = Dir(rep & "*.jpg") ' première image
  Do While nf <> ""
    Cells(lig, col).Select
    On Error Resume Next
    Set monimage = ActiveSheet.Pictures.Insert(rep & nf)
    If Err = 0 Then
      ActiveCell.EntireRow.RowHeight = monimage.Height + 6
      ActiveCell.EntireColumn.ColumnWidth = (monimage.Width / 4.75) + 0.5
      monimage.Top = ActiveCell.Top + 2
      monimage.Left = ActiveCell.Left + 3
      monimage.Name = Left(nf, Len(nf) - 4)
      Cells(lig + 1, col) = Application.Proper(Left(nf, Len(nf) - 4))
      col = col + 1
      If col = NbImagesLigne + 1 Then col = 1: lig = lig + 2
    End If
    On Error GoTo 0
    nf = Dir ' image suivante
  Loop
End Sub

Sub suppression()
  For Each i In ActiveSheet.Shapes
    If i.Type = 13 Then i.Delete
  Next i
End Sub

cas2: On adapte la hauteur de la photo à celle de la cellule

Sub InsereImagesBloc2()
  suppression
  rep = "c:\mesdoc\" ' adapter
  NbImagesLigne = 3 ' adapter
  lig = 3
  col = 1
  nf = Dir(rep & "*.jpg") ' première image
  Do While nf <> ""
    Cells(lig, col).Select
    On Error Resume Next
    Set monimage = ActiveSheet.Pictures.Insert(rep & nf)
    If Err = 0 Then
      ech = (monimage.Height) / (ActiveCell.Height - 4)
      monimage.Height = ActiveCell.Height - 4
      monimage.Width = monimage.Width / ech
      monimage.Top = ActiveCell.Top + 2
      monimage.Left = ActiveCell.Left + 3
      monimage.Name = Left(nf, Len(nf) - 4)
      Cells(lig + 1, col) = Application.Proper(Left(nf, Len(nf) - 4))
      col = col + 1
      If col = NbImagesLigne + 1 Then col = 1: lig = lig + 2
    End If
    On Error GoTo 0
    nf = Dir ' image suivante
  Loop
End Sub

Sub suppression()
   For Each i In ActiveSheet.Shapes
     If i.Type = 13 Then i.Delete
   Next i
End Sub

Centrage d'images dans les cellules

Sub centreImages()
  For Each s In ActiveSheet.Shapes
    If s.Type = 13 Then
      Set c = Range(s.TopLeftCell.Address)
      s.Left = c.Left + c.Width / 2 - s.Width / 2
      s.Top = c.Top + c.Height / 2 - s.Height / 2
    End If
  Next s
End Sub

Modifie la largeur et la hauteur des cellules et centre les images

CentreImages

Sub centreImages()
  Cells.SpecialCells(xlCellTypeConstants, 23).EntireColumn.AutoFit
  For Each c In Cells.SpecialCells(xlCellTypeConstants, 23)
    For Each s In ActiveSheet.Shapes
      If s.TopLeftCell.Address = c.Offset(1, 0).Address _
          Or s.TopLeftCell.Address = c.Address Then
        s.Name = c
        s.Left = c.Offset(1, 0).Left + c.Offset(1, 0).Width / 2 - s.Width / 2
        s.Top = c.Offset(1, 0).Top + 5
        c.Offset(1, 0).EntireRow.RowHeight = s.Height + 10
      End If
    Next s
  Next
End Sub

Import d'images à partir de leurs url

import images url

'http://www.ex-designz.net/apidetail.asp?api_id=498
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
  Dim lngRetVal As Long
  lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
  If lngRetVal = 0 Then DownloadFile = True
End Function

Sub essai()
   DownloadFile "http://www.google.fr/images/srpr/logo3w.png", "c:\mesdoc\google.png"
End Sub

Fonction d'affichage d' images externes

Si les images sont dans le même répertoire que le classeur

En B2: =afficheimage(A2&".jpg")

Si les images sont dans le répertoire c:\mesdoc\

En B2: =afficheImage(A2&".jpg";"c:\mesdoc\")

AfficheImage
ChoixImageFonction
AfficheImageChemin

Function AfficheImage(NomImage, Optional rep As String)
  Application.Volatile
  If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
  Set f = Sheets(Application.Caller.Parent.Name)
  Set adr = Application.Caller
  Set adr2 = Range(adr.Address).MergeArea
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
     If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
    For Each k In adr.Worksheet.Shapes
       If Mid(k.Name, InStr(k.Name, "_") + 1) = adr.Address Then k.Delete
    Next k
    f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr2.Width, adr2.Height).Name = NomImage & "_" &        adr.Address
  End If
End Function

L'image prend la hauteur de la cellule et respecte les proportions

AfficheImage3
ChoixImageFonction
AfficheImageCentrée
AfficheImage4
FonctionAffichageImageExterne

Function AfficheImage(NomImage, Optional rep)
  Application.Volatile
   If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
   Set f = Sheets(Application.Caller.Parent.Name)
   Set adr = Application.Caller
   temp = NomImage & "_" & adr.Address
   Existe = False
   For Each s In adr.Worksheet.Shapes
      If s.Name = temp Then Existe = True
   Next s
   If Not Existe Then
     For Each k In adr.Worksheet.Shapes
       p = InStr(k.Name, "_")
       If Mid(k.Name, p + 1) = adr.Address Then k.Delete
   Next k
   If Dir(rep & NomImage) = "" Then
     AfficheImage = "Inconnu"
   Else
     Set myShell = CreateObject("Shell.Application")
     If TypeName(rep) = "Range" Then
       Set myFolder = myShell.Namespace(rep.Value)
     Else
       Set myFolder = myShell.Namespace(rep)
     End If
     Set myFile = myFolder.Items.Item(NomImage)
     Taille = myFolder.GetDetailsOf(myFile, 26)
     H = Val(Split(Taille, "x")(1))
     L = Val(Split(Taille, "x")(0))
     Ech = adr.Height / H
     H = H * Ech
     L = L * Ech
     f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H).Name = NomImage & "_" & adr.Address
     AfficheImage = "ok"
   End If
  End If
End Function

L'image prend la hauteur ou la largeur de la cellule et respecte les proportions

AfficheImageHauteurOUlargeur
ImagesCellulesFusionnées

On peut également afficher unephoto dans un commentaire de cellule sans modifier la taille de la cellule.

Affichage dans un commentaire

Insertion d'une image dans des cellules fusionnées

Occupe la surface des cellules fusionnées.

FonctionImageMerge

Function AfficheImage(NomImage, Optional rep As String)
  Application.Volatile
  If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
  Set f = Sheets(Application.Caller.Parent.Name)
  Set adr = Application.Caller
  Set adr2 = Range(adr.Address).MergeArea
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
    If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
     For Each k In adr.Worksheet.Shapes
       P = InStr(k.Name, "_")
       If Mid(k.Name, P + 1) = adr.Address Then k.Delete
    Next k
    f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr2.Width, adr2.Height).Name = NomImage & "_" & adr.Address
  End If
End Function

Trombinoscope

On veut afficher les photos des noms d'une BD sur une page.

-Pour récupérer les noms de la BD avec 4 noms par ligne.
 En A2: =DECALER(BD!$A$2;(ENT(LIGNES($1:2)/2)*4+COLONNES($A:A)-5);0)

-Pour afficher la photo du nom en A2:
 En A1: =AfficheImage(A2&".jpg";"c:\mesdoc\")

Les ajouts et suppressions de noms sont gérés automatiquement.

Trombinoscope

Function AfficheImage(NomImage, Optional rep)
  Application.Volatile
  If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
  Set f = Sheets(Application.Caller.Parent.Name)
  Set adr = Application.Caller
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
    If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
     For Each k In adr.Worksheet.Shapes
       p = InStr(k.Name, "_")
       If Mid(k.Name, p + 1) = adr.Address Then k.Delete
    Next k
    If Dir(rep & NomImage) = "" Then
       AfficheImage = "."
    Else
       f.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr.Width,adr.Height).Name= NomImage & "_" & adr.Address
       AfficheImage = "ok"
    End If
  Else
    AfficheImage = "ok"
  End If
End Function

Export image interne en gif

ExportImage

Sub ExportImage()
  répertoire = ThisWorkbook.Path
  Set f = ActiveSheet
  nomShape = "Pédalier"
  Set img = f.Shapes(nomShape)
  img.CopyPicture
  f.ChartObjects.Add(0, 0, img.Width, img.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:=répertoire & "\" & "monimage.jpg", FilterName:="jpg"
  f.ChartObjects(1).Delete
End Sub

Exporte un champ sous forme de fichier Gif

ExportChamp

Sub ExportZoneTableau()
  Set f = ActiveSheet
  f.Range("A1").CurrentRegion.Select
  Set champExport = Selection
  champExport.CopyPicture
  f.ChartObjects.Add(0, 0, champExport.Width, champExport.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export "imageExport.gif", "gif"
  f.ChartObjects(1).Delete
End Sub

Transforme un graphe en image

Sub EditionCopierImage()
For Each i In Sheets("GrapheImage").Shapes ' Raz images sur graphe image
Sheets("GrapheImage").Shapes(i.Name).Delete
Next i
'-- Copy Graph --> Image
Sheets("Graphe").ChartObjects(1).CopyPicture ' copy
Worksheets("GrapheImage").Paste Destination:=Worksheets("GrapheImage").Range("B3")
End Sub

Exporte un graphe en gif

Set g = Sheets("GrapheMois").ChartObjects(1).Chart
fichier = ActiveWorkbook.Path & "\" & "graphe.gif"
g.Export Filename:=fichier, FilterName:="GIF"

Exemples

Défilement d'un texte dans une zone de texte

Créer une zone de texte et la nommer MonShape



DéfileShape.xls
DéfileShape2.xls

Sub defile()
  t = "Le message qui défile pendant un temps donné ..."
  n = 0
  Do While n < 200
    t = Right(t, Len(t) - 1) & Left(t, 1)
    ActiveSheet.Shapes("monshape").TextFrame.Characters.Text = Left(t, 50)
    w = 0.1
    temp = Timer
    Do While Timer < temp + w
      DoEvents
    Loop
    n = n + 1
  Loop
End Sub

Clignotement d'un shape

ClignotementShape
ClignotementShape2

Sub Clignote()
 n = 0
 Do While n < 10
   ActiveSheet.Shapes("Clignotant").Visible = True
   fin = Timer + 0.4
   Do While Timer < fin
     DoEvents
   Loop
   ActiveSheet.Shapes("Clignotant").Visible = False
   fin = Timer + 0.2
   Do While Timer < fin
     DoEvents
   Loop
   n = n + 1
  Loop
End Sub

Dans un shape, on affiche Bravo avec clignotement si le total des nombres est >100.
Créer une zone de texte et la nommer MonShape (en haut à gauche de la barre de formule-valider avec Entrée)

ImageCondClignote

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([B2:B6], Target) Is Nothing And Target.Count = 1 Then
   If [B7] > 100 Then
      Shapes("monshape").Visible = True
      Shapes("monshape").TextFrame.Characters.Text = "Bravo! " & _
       Chr(10) & Format([B7], "0 K€")
      Clignote "monshape", 10
    Else
      Shapes("monshape").Visible = False
    End If
  End If
End Sub

Sub Clignote(s, nb)
  n = 0
  Do While n < nb
    ActiveSheet.Shapes(s).Visible = False
    fin = Timer + 0.2
    Do While Timer < fin: DoEvents: Loop
      ActiveSheet.Shapes(s).Visible = True
      fin = Timer + 0.4
      Do While Timer < fin: DoEvents: Loop
      n = n + 1
   Loop
End Sub

On fait clignoter une image si le total en B7 dépasse 100
-Créer une image de la cellule B7 avec l'appareil photo (ou Edition/copier puisMaj+edition/coller l'image avec liaison)
et la nommer MonShape (en haut à gauche de la barre de formule
-valider avec Entrée)

ImageCondClignote2

Message d'attente

-Créer une zone de texte et la nommer Message(en haut à gauche de la barre de formule-valider avec Entrée)

Message Attente
Temporisation
PubShape
HorlogeShape
Animation

Sub Attente2()
  ActiveSheet.Shapes("message").Visible = True
  ActiveSheet.Shapes("message").TextFrame.Characters.Text = "Attendez svp..."
  Application.Wait (Now + TimeValue("00:00:01"))
  '--- simulation attente
  For i = 1 To 200000000

  Next i
  '---
  ActiveSheet.Shapes("message").Visible = False
End Sub

Version non bloquante

Sub TempoNonBloquante()
  Sheets("Attente2").Shapes("message").Visible = True
  fin = Timer + 10
  Do While Timer < fin
    DoEvents
  Loop
  Sheets("Attente2").Shapes("message").Visible = False
End Sub

Planning

PlanningShapes

Sub planning2()
  Sheets(2).DrawingObjects.Delete
  Sheets(2).[A5:BB20].ClearContents
  Sheets(2).[A5:BB20].Interior.ColorIndex = xlNone
  Sheets(2).[A5:BB20].Font.Bold = False
  Sheets(2).[A5:BB20].ClearComments
  Sheets(2).Select
  ligneBd = 2
  [A2].Select
  ligne = 5
  Do While Sheets(1).Cells(ligneBd, 1) <> ""
    mcible = Sheets(1).Cells(ligneBd, 1)
    Sheets(2).Cells(ligne, 1).Value = mcible
    Do While mcible = Sheets(1).Cells(ligneBd, 1)
      mTitreAction = Sheets(1).Cells(ligneBd, 2)
      semaine = Sheets(1).Cells(ligneBd, 3)
      semainefin = Sheets(1).Cells(ligneBd, 4)
      déb = 1
      lg = Len(mTitreAction)
      P = Application.Match(Sheets(1).Cells(ligneBd, 8), Sheets(2).[A2:F2], 0)
      If Not IsError(P) Then coul = Sheets(2).[A1].Offset(0, P)
        If semainefin >= semaine Then
          début = Cells(ligne, semaine + 1).Left - 0
          larg = Cells(ligne, semaine + 1).Width
          fin = début + larg * (semainefin - semaine)
          y = Cells(ligne, semaine + 1).Top + 10
          Sheets(2).Shapes.AddTextbox(msoTextOrientationHorizontal, début, y, larg * (semainefin - semaine + 1), 28).Select
          Selection.ShapeRange.Fill.ForeColor.SchemeColor = coul
          Selection.Characters.Text = mTitreAction
          Selection.Characters(Start:=1, Length:=99).Font.Size = 7
       End If
       ligneBd = ligneBd + 1
     Loop
     ligne = ligne + 1
   Loop
   [A2].Select
End Sub

Copie un champ dans un formulaire

ChampForm

Private Sub UserForm_Initialize()
  rep = ActiveWorkbook.Path & "\"
  With Sheets("shapeForm")
    Set champ = .Range("A1:E6")
    champ.CopyPicture
    .ChartObjects.Add(0, 0, champ.Width, champ.Height * 1.15).Chart.Paste
    .ChartObjects(1).Chart.Export Filename:=rep & "monimage.gif", FilterName:="gif"
    .ChartObjects(1).Delete
  End With
  Me.Image1.Picture = LoadPicture(rep & "monimage.gif")
End Sub

Chronomètre

Chrono


Dim tempsChrono
Dim chrono As Double

Sub majChrono()
'Sheets("Chrono").Shapes("MonChrono").TextFrame.Characters.Text = chrono & " s"
temp = chrono / 3600
Sheets("Chrono").Shapes("MonChrono").TextFrame.Characters.Text = Format(temp / 24, "hh:mm:ss")
chrono = chrono + 1
tempsChrono = Now + TimeValue("00:00:1")
Application.OnTime tempsChrono, "majChrono"
End Sub

Sub matache()
chrono = 0
majChrono
End Sub

Sub ArretChrono()
On Error Resume Next
Application.OnTime tempsChrono, Procedure:="majChrono", Schedule:=False
End Sub

Loupe

Affiche dans un shape le contenu de la cellule active. Si le shape est détruit, il est recrée par le programme.

Loupe

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error Resume Next
  If Target.Count = 1 And Shapes("monshape").Visible = True Then
    If Err <> 0 Then creeShape
    Shapes("monshape").Left = ActiveCell.Left
    Shapes("monshape").Top = ActiveCell.Top + ActiveCell.Height + 3
    Shapes("monshape").TextFrame.Characters.Text = ActiveCell
  End If
End Sub

Le double clic permet de masquer/Afficher la loupe

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Shapes("monshape").Visible = Not Shapes("monshape").Visible
  If Shapes("monshape").Visible Then
    Shapes("monshape").Left = ActiveCell.Left
    Shapes("monshape").Top = ActiveCell.Top + ActiveCell.Height + 3
    Shapes("monshape").TextFrame.Characters.Text = ActiveCell
  End If
  Cancel = True
End Sub

Sub creeShape()
Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 180, 50).Select
Selection.Font.Name = "Verdana"
Selection.Font.Size = 13
Selection.Name = "monshape"
Shapes("monshape").Left = ActiveCell.Left
Shapes("monshape").Top = ActiveCell.Top + ActiveCell.Height + 3
End Sub

Loupe

Double-clic pour faire apparaître/disparaître la loupe

Loupe6
ZoomChampSurvol

-Créer la loupe avec Copier/Maj+Edition/Coller image avec liaison
-Nommer l'image Monshape

Dim témoinLoupe
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not témoinLoupe Then
    If Target.Count = 1 Then
      If Target <> "" Then
        Shapes("monshape").Visible = True
        ActiveSheet.Shapes("monshape").Left = Target.Left + 5
        ActiveSheet.Shapes("monshape").Top = Target.Top + Target.Height + 10
        ActiveSheet.Shapes("monshape").Width = Target.Width * 2
        ActiveSheet.Shapes("monshape").Height = Target.Height * 2
        ActiveSheet.Shapes("monshape").DrawingObject.Formula = Target.Address
     Else
       Shapes("monshape").Visible = False
     End If
   End If
 End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  témoinLoupe = Not témoinLoupe
  If Not témoinLoupe Then
    Shapes("monshape").Visible = True
    ActiveSheet.Shapes("monshape").Left = Target.Left + 5
    ActiveSheet.Shapes("monshape").Top = Target.Top + Target.Height + 10
    ActiveSheet.Shapes("monshape").Width = Target.Width * 2
    ActiveSheet.Shapes("monshape").Height = Target.Height * 2
    ActiveSheet.Shapes("monshape").DrawingObject.Formula = Target.Address
  Else
    Shapes("monshape").Visible = False
  End If
  Cancel = True
End Sub

Version sans shape

Loupe4

Const FontEch = 1.5
Const LargeurEch = 1.6
Dim témoinLoupe
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Count = 1 And Not témoinLoupe Then
    On Error Resume Next
    Application.ScreenUpdating = False
    Range([mémo]).Font.Size = Range([mémo]).Font.Size / FontEch
    Range([mémo]).ColumnWidth = Range([mémo]).ColumnWidth / LargeurEch
    Range([mémo]).RowHeight = CDbl([mémoH])
    '--
    ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & Target.Address & Chr(34)
    ActiveWorkbook.Names.Add Name:="mémoH", RefersToR1C1:="=" & Chr(34) & Target.RowHeight & Chr(34)
    Target.Font.Size = Target.Font.Size * FontEch
    Target.ColumnWidth = Target.ColumnWidth * LargeurEch
    Target.Rows.AutoFit
  End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Count = 1 Then
    Application.ScreenUpdating = False
    If Not témoinLoupe Then
      On Error Resume Next
      Range([mémo]).Font.Size = Range([mémo]).Font.Size / FontEch
      Range([mémo]).ColumnWidth = Range([mémo]).ColumnWidth / LargeurEch
      Range([mémo]).RowHeight = CDbl([mémoH])
   Else
     ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & Target.Address & Chr(34)
     ActiveWorkbook.Names.Add Name:="mémoH", RefersToR1C1:="=" & Chr(34) & Target.RowHeight & Chr(34)
     Target.Font.Size = Target.Font.Size * FontEch
     Target.ColumnWidth = Target.ColumnWidth * LargeurEch
     Target.Rows.AutoFit
   End If
   témoinLoupe = Not témoinLoupe
  End If
  Cancel = True
End Sub

Visualise une fiche dans un shape

Cliquer sur le nom pour faire apparaître la fiche.

-Préparer le modèle de la fiche en M2:N5
-Créer un shape avec l'appareil photo ou Edition/Copier puis Maj+Coller l'image avec liaison
-Nommer le shape Monshape

LoupeFiche
LoupeFiche2

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
    [n2] = Target
    [n3] = Target.Offset(0, 1)
    [n4] = Target.Offset(0, 2)
    [n5] = Target.Offset(0, 3)
    Shapes("monshape").Left = ActiveCell.Offset(0, 4).Left + 5
    Shapes("monshape").Top = ActiveCell.Top
  End If
End Sub

Zoom d'un champ au survol du champ

ZoomChampSurvol

1-Edition/copier du champ E1:I6
2-Maj+Edition/coller image avec liaison
3-Agrandir la copie
4-Nommer la copie Monca
5-Avec la Boîte à outils Contrôle, créer une image Image1
6-La superposer sur le champ
7-La rendre transparente:propriété backstyle: fmBackstyleTransparent

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
      ActiveSheet.Shapes("Monca").Visible = False
  Else
      ActiveSheet.Shapes("monca").Visible = True
  End If
End Sub

Private Sub Image1_Click()
  ActiveSheet.Image1.Visible = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   On Error Resume Next
  ActiveSheet.Image1.Visible = True
End Sub

Générique

Un shape nommé MonShape contenant du texte est placé entre 2 shapes invisibles. On le fait défiler
verticalement .

Générique
Texte Défilant Shape

Un shape est placé entre 2 shapes invisibles

Ce que l'on voit

 


For y = 1 To 170
   ActiveSheet.Shapes("monshape").Left = 220
   ActiveSheet.Shapes("monshape").Top = y
   w = 0.04
   temp = Timer
   Do While Timer < temp + w
     DoEvents
   Loop
 Next y

Compter le nombre d'images dans un champ

Function CompteImages(champ As Range)
  Application.Volatile
  For Each s In ActiveSheet.Shapes
    If Not Intersect(Range(s.TopLeftCell.Address), champ) Is Nothing Then
       n = n + 1
    End If
   Next
   CompteImages = n
End Function

Function CompteImages2(champ As Range, nomImage)
   Application.Volatile
   For Each s In ActiveSheet.Shapes
     If Not Intersect(Range(s.TopLeftCell.Address), champ) Is Nothing Then
       If s.Name = nomImage Then n = n + 1
     End If
   Next
  CompteImages2 = n
End Function

Modifier la forme des commentaires

CmtForme

Sub CreeShapes()
  i = 1
  For Each c In ActiveSheet.Comments
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeCross, _
       Left:=c.Parent.Left + c.Parent.Width - 9, Top:=c.Parent.Top, Width:=9, Height:=9)
      .Fill.ForeColor.RGB = RGB(255, 255, 255)
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .Name = "commentaire" & i
    i = i + 1
   End With
  Next
End Sub

Sub SupShapes()
   For Each s In ActiveSheet.Shapes
     If Left(s.Name, 11) = "commentaire" Then s.Delete
   Next s
End Sub

Commentaires avec triangle vert

Pour faire apparaître les commentaires avec un triangle vert.

TriangleVert

Sub CreeShapes()
   i = 1
   For Each c In ActiveSheet.Comments
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
        Left:=c.Parent.Left + c.Parent.Width - 4, Top:=c.Parent.Top + 1, Width:=4, Height:=4)
       .Fill.ForeColor.RGB = RGB(0, 255, 0)
       .Line.ForeColor.RGB = RGB(0, 255, 0)
       .IncrementRotation 180
       .Name = "commentaire" & i
       i = i + 1
   End With
  Next
End Sub

Autres formes

msoShapeDownArrow
msoShapeSmileyFace
msoShapeCloudCallout
msoShapeRightArrow
msoShapeOvalCallout
msoShapeIsoscelesTriangle
msoShapeHeart
msoShapecross

Fonction renvoyant le nom d'une image dans une cellule

Function NomShapeCellule(adr)
  For Each s In ActiveSheet.Shapes
    If s.TopLeftCell.Address = adr.Address Then
       NomShapeCellule = s.Name
    End If
  Next s
End Function

Fonction renvoyant la taille d'une image en points

Function TailleImg(nom)
  TailleImg = ActiveSheet.Shapes(nom).Width & "x" & ActiveSheet.Shapes(nom).Height
End Function

Curseur rouge

Encadre la cellule active ou la sélection en rouge. On peut aussi choisir une forme ovale.

Curseur Rouge

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error Resume Next
  ActiveSheet.Shapes("Curseur").Visible = True
  If Err <> 0 Then
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 6, 6, 8, 6).Name = "curseur"
    ActiveSheet.Shapes("Curseur").Fill.Visible = msoFalse
    ActiveSheet.Shapes("curseur").Line.Visible = True
    ActiveSheet.Shapes("curseur").Line.ForeColor.SchemeColor = 10
    ActiveSheet.Shapes("curseur").Line.Weight = 3
  End If
  ActiveSheet.Shapes("curseur").Left = Target.Left
  ActiveSheet.Shapes("curseur").Top = Target.Top
  ActiveSheet.Shapes("curseur").Height = Selection.Height
  ActiveSheet.Shapes("curseur").Width = Selection.Width
End Sub

Curseur horizontal

CurseurHorizontal

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set champ = [B3:E21]
  If Not Intersect(champ, Target) Is Nothing Then
    On Error Resume Next
    Shapes("curseurH").Visible = True
    If Err <> 0 Then ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1000, 1).Name = "curseurH"
    ActiveSheet.Shapes("curseurH").Line.ForeColor.RGB = RGB(255, 0, 0)
    Shapes("curseurH").Top = ActiveCell.Top + ActiveCell.Height
    Shapes("curseurH").Height = 1
    Shapes("curseurH").Width = champ.Width
    Shapes("curseurH").Left = champ.Left
    ActiveSheet.Shapes("curseurv").Line.ForeColor.RGB = RGB(255, 0, 0)
  Else
    On Error Resume Next
    Shapes("curseurH").Visible = False
  End If
End Sub

Curseur vertical

CurseurVertical

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set champ = [b4:BK7]
  If Not Intersect(champ, Target) Is Nothing Then
    On Error Resume Next
    Shapes("curseur").Visible = True
    If Err <> 0 Then  ActiveSheet.Shapes.AddTextbox(msoTextOrientationVertical, 1, 1, 1, 1).Name = "curseur"
     Shapes("curseur").Fill.Solid
     Shapes("curseur").Fill.ForeColor.SchemeColor = 10
     Shapes("curseur").Line.ForeColor.RGB = RGB(255, 0, 0)
     Shapes("curseur").Top = champ.Top
     Shapes("curseur").Left = ActiveCell.Left - 3
     Shapes("curseur").Height = champ.Height
     Shapes("curseur").Width = 2
   Else
     On Error Resume Next
     Shapes("curseur").Visible = False
   End If
End Sub

Curseur triangle

CurseurTriangle

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error Resume Next
  ActiveSheet.Shapes("Curseur").Visible = True
  If Err <> 0 Then
    ActiveSheet.Shapes.AddShape(7, 6, 6, 8, 6).Name = "Curseur"
    ActiveSheet.Shapes("Curseur").Fill.ForeColor.SchemeColor = 2
    ActiveSheet.Shapes("curseur").IncrementRotation 90
    ActiveSheet.Shapes("curseur").Line.Visible = msoFalse
  End If
  ActiveSheet.Shapes("curseur").Left = Target.Left + 4
  ActiveSheet.Shapes("curseur").Top = Target.Top + 2
  ActiveSheet.Shapes("curseur").Height = 6
  ActiveSheet.Shapes("curseur").Width = 8
End Sub

Photos en commentaire

ImagesCommentaire

Sub CommentImages()
  repertoire = ThisWorkbook.Path & "\"
  For Each c In Range("A2", [A65000].End(xlUp))
    c.ClearComments
    c.AddComment
    c.Comment.Text Text:=CStr(c)
    fichier = CStr(c.Value) & ".jpg"
    If Dir(repertoire & fichier) <> "" Then
       c.Comment.Shape.Fill.UserPicture repertoire & fichier
       taille = TaillePixelsImage(repertoire, fichier)
       c.Comment.Shape.Height = Val(Split(taille, "x")(1))
       c.Comment.Shape.Width = Val(Split(taille, "x")(0))
       c.Comment.Shape.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
       c.Comment.Shape.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
    End If
  Next
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Diagonale dans une cellule

CréeDiago

Sub essai()
  CreeShapes Range("B2"), "texte1", "texte2"
  CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
   On Error Resume Next
   ActiveSheet.Shapes(c.Address & "1").Delete
   ActiveSheet.Shapes(c.Address & "2").Delete
   With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
       .OLEFormat.Object.Characters.Text = texte1
       .OLEFormat.Object.Characters.Font.Size = 7
       .Fill.ForeColor.RGB = RGB(255, 0, 0)
       .Line.ForeColor.RGB = RGB(255, 0, 0)
       .IncrementRotation 180
        .Name = c.Address & "1"
    End With
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
      Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
      .OLEFormat.Object.Characters.Text = texte2
      .OLEFormat.Object.Characters.Font.Size = 7
      .Fill.ForeColor.RGB = RGB(0, 255, 0)
      .Line.ForeColor.RGB = RGB(0, 255, 0)
      .Name = c.Address & "2"
    End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

Visualisation d'une fiche dans un shape

-Définir un modèle de fiche en R2:S4
-Créer un shape MonShape avec l'appareil photo.

VisuFicheShape

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([B2:G8], Target) Is Nothing And Target.Count = 1 Then
    If Target <> "" Then
      Set p = Application.Index([Base], , 1).Find(what:=Target, lookat:=xlWhole)
      If Not p Is Nothing Then
         ActiveSheet.Shapes("monShape").Visible = True
         [s2] = Target
         Shapes("monshape").Left = Target.Offset(, 1).Left + 5
         Shapes("monshape").Top = Target.Top
       End If
    Else
       ActiveSheet.Shapes("monShape").Visible = False
    End If
  Else
     ActiveSheet.Shapes("monShape").Visible = False
  End If
End Sub

Création d'une arborescence/organigramme dynamique à partir d'une BD

Organigramme

Autre version avec Shapes (ne fonctionne pas sur Excel 2003)

OrganigrammePhoto2

Arborescence/Organigramme hiérarchique dynamique d'une base de données avec shapes

Différentes façons de représenter des informations sous forme d'arborescence.

OrganigrammeH
OrganigrammeH Liens Sup
OrganigrammeHClic
OrganigrammeH Survol
OrganigrammeV
OrganigrammeMaterielVClic
Organigramme Généalogie
Organigramme Généalogie branche choisie
Classe ArbreTableau
ArbreTableau
Classe ArbreDictionary



Dim colonne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrga()
  Set forga = Sheets("orgaShapes")
  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
  inth = 70
  intv = 60
  colonne = 0
  Set débutOrg = forga.Range("c4")
  créeShape Tbl(1, 1), 1, Tbl(1, 3), f.Cells(2, 1).Interior.Color
End Sub

Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
  hauteurshape = 48
  largeurshape = 85
  colonne = colonne + 1
  forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 1
  txt = parent & vbLf & 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
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 3
    .Fill.ForeColor.RGB = coul
  End With
  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), f.Cells(i + 1, 1).Interior.Color
  Next i
End Sub

Avec photo

Organigramme Photo
Organigramme PhotoArrièrePlan

Photo en arrière-plan

Autre version avec regroupements de noms au 3e niveau

Organigramme

Généalogie avec shapes

Avec la seconde version, on visualise la branche choisie de l'arbre généalogique.

Organigramme Généalogie
Organigramme Généalogie branche choisie
Arbre Généalogique (pedigree) branche choisie

Ci dessous, on obtient l'arbre généalogique des ascendants pour la ligne choisie dans la base de données.

Arbre généalogique (pedigree) branche choisie

 

Nomenclature avec shapes

NomenclatureV
NomenclatureH

Nomenclature2

Carte de france

Positionne un curseur en fonction de la région choisie en col A.

France

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  xfrance = ActiveSheet.Shapes("france").Left
  yfrance = ActiveSheet.Shapes("france").Top
  If Not Intersect([A3:A100], Target) Is Nothing And Target.Count = 1 Then
    ActiveSheet.Shapes("pointeur").Top = Target.Offset(, 2) + yfrance
    ActiveSheet.Shapes("pointeur").Left = Target.Offset(, 1) + xfrance
  End If
End Sub

Récupération des coordonnées XY d'une région

-placer le pointeur rouge sur la région
-placer le curseur dans la colonne B
-puis clic

Sub recupXY()
ActiveCell = ActiveSheet.Shapes("pointeur").Left - ActiveSheet.Shapes("france").Left
ActiveCell.Offset(, 1) = ActiveSheet.Shapes("pointeur").Top - ActiveSheet.Shapes("france").Top
End Sub

Affiche un commentaire sur la région choisie

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 xfrance = ActiveSheet.Shapes("france").Left
  yfrance = ActiveSheet.Shapes("france").Top
  If Not Intersect([A2:A100], Target) Is Nothing And Target.Count = 1 Then
    ActiveSheet.Shapes("commentaire").Top = Target.Offset(, 2) + yfrance
    ActiveSheet.Shapes("commentaire").Left = Target.Offset(, 1) + xfrance
    ActiveSheet.Shapes("commentaire").TextFrame.Characters.Text = Target.Offset(, 3)
  End If
End Sub

Affiche un commentaire au survol de chaque région

SurvolRegionForm
SurvolRegionTableur



Dim Lbl(1 To 23) As New ClasseLabel
Private Sub UserForm_Initialize()
  i = 0
  For Each c In Me.Controls
    temp = c.Name
    If TypeName(c) = "Label" And temp <> "Commentaire" Then
      i = i + 1
      Set Lbl(i).GrLabels = Me(temp)
    End If
  Next c
End Sub

Module de classe ClasseLabel

Public WithEvents GrLabels As Msforms.Label
Private Sub GrLabels_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Set result = [a:a].Find(what:=Replace(GrLabels.Name, "_", " "))
  If Not result Is Nothing Then
    UserForm1.Commentaire.Caption = " Région " & Cells(result.Row, 1) & Chr(10) & _
     " " & Cells(result.Row, 2)
     UserForm1.Commentaire.Left = GrLabels.Left
     UserForm1.Commentaire.Top = GrLabels.Top
   End If
End Sub

Affiche le ca dans les bulles de chaque région

Sub BullesCA()
  Set f = Sheets("BullesCa")
  ech = 30000 / Application.Max([B:B])
  For Each c In f.Range([A2], f.[A65000].End(xlUp))
    temp = (c.Offset(, 1) / 1000 * ech * ech) ^ 0.5
    f.Shapes(c).Height = temp
    f.Shapes(c).Width = temp * 1.1
    f.Shapes(c).TextFrame.Characters.Text = c.Offset(, 1)
    f.Shapes(c).OLEFormat.Object.Font.Size = 6
  Next c
End Sub

Positionne le curseur sur la région choisie dans la carte

Sub région()
régionChoisie = Application.Caller
[ListeRégions].Find(what:=régionChoisie).Resize(, 2).Select
End Subs

Donne les coordonnées du curseur dans le tableur au survol de la souris

GetCursor

Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As LongDim TimerOn As Boolean
Dim TimerOn As Boolean
Dim TimerId As Long

Type POINT
  X As Long
  Y As Long
End Type

Public Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim p As POINTAPI
  On Error Resume Next
  GetCursorPos p
  Set champ = ActiveWindow.RangeFromPoint(p.X, p.Y)
  If champ.Row <= 10 And champ.Column <= 10 Then
    Cells(champ.Row, champ.Column).Select
    ActiveSheet.Shapes("zone").TextFrame.Characters.Text = Cells(champ.Row, champ.Column)
    ActiveSheet.Shapes("zone").Left = ActiveCell.Left + ActiveCell.Width + 5
    Cells(1, 1) = champ.Row & "*" & champ.Column
  End If
End Function

Sub DébutTimer()
   If Not TimerOn Then
      TimerId = SetTimer(0, 0, 5, AddressOf TimerProc)
      TimerOn = True
   End If
End Sub

Sub FinTimer()
  If TimerOn Then
    KillTimer 0, TimerId
    TimerOn = False
  End If
End Sub

Sub auto_close()
  FinTimer
End Sub

Donne les coordonnées du curseur à l'écran au survol de la souris

Curseur

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long
Public Type POINT
  x As Long
  y As Long
End Type
Public p As POINT
Public boucle

Sub essai()
  boucle = True
  Do While boucle
  GetCursorPos p
    [C1] = p.x
    [D1] = p.y
    DoEvents
  Loop
End Sub

Sub fin()
  boucle = False
End Sub

Affichage d'une image externe dans un formulaire

Version simplifiée

Les images ont la même taille. On clique sur le nom de l'image en colonne A. L'image apparaît dans un formulaire.
On suppose que les images externes sont dans le même répertoire que le classeur Excel.

AfficheImage1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    If Target <> "" Then
      répertoireImage = ThisWorkbook.Path ' à adapter
      NomImage = Target
      If Dir(répertoireImage & "\" & NomImage & ".jpg") <> "" Then
         UserForm1.Image1.PictureSizeMode = fmPictureSizeModeStretch
         UserForm1.Image1.Picture = LoadPicture(répertoireImage & "\" & NomImage & ".jpg")
         UserForm1.Show
      End If
    End If
  End If
End Sub

La largeur du formulaire est adaptée à la largeur de l'image.

AfficheImage2

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    If Target <> "" Then
      répertoireImage = ThisWorkbook.Path ' à adapter
      NomImage = Target
      If Dir(répertoireImage & "\" & NomImage & ".jpg") <> "" Then
        taille = TaillePixelsImage(répertoireImage, NomImage & ".jpg")
        rap = Val(Split(taille, "x")(0)) / Val(Split(taille, "x")(1))
        UserForm1.Image1.Height = 200 ' on fixe la hauteur
        UserForm1.Image1.Width = UserForm1.Image1.Height * rap
        UserForm1.Height = UserForm1.Image1.Height + 20
        UserForm1.Width = UserForm1.Image1.Width
        UserForm1.Image1.Picture = LoadPicture(répertoireImage & "\" & NomImage & ".jpg")
        UserForm1.Show
      End If
    End If
  End If
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Sur cette version, on clique sur une image miniature

L'opérateur clique sur une image miniature interne au classeur pour afficher dans un formulaire l'image externe correspondante. Le nom de la photo externe=nom de l'image miniature interne.

AfficheImage

Sub Affichephoto()
  répertoire = ThisWorkbook.Path
  NomImage = Application.Caller
  If Dir(répertoire & "\" & NomImage & ".jpg") <> "" Then
    taille = TaillePixelsImage(répertoire, NomImage & ".jpg")
    rap = Val(Split(taille, "x")(0)) / Val(Split(taille, "x")(1))
    UserForm1.Image1.Height = 120
    UserForm1.Image1.Width = UserForm1.Image1.Height * rap
    UserForm1.Height = UserForm1.Image1.Height + 20
    UserForm1.Width = UserForm1.Image1.Width
    UserForm1.Image1.Picture = LoadPicture(répertoire & "\" & NomImage & ".jpg")
    UserForm1.Show
  End If
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Recherche d'images externes par mot clé

Les mots clés sont définis dans la zone commentaires des images (propriétés)

RechercheImages

Dim repertoireImages
Private Sub UserForm_Initialize()
  repertoireImages = ThisWorkbook.Path & "\" ' adapter
  Set mondico = CreateObject("Scripting.Dictionary")
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoireImages)
  nf = Dir(repertoireImages & "*.jpg")
  Do While nf <> ""
    Set myFile = myFolder.items.Item(nf)
    cmt = myFolder.GetDetailsOf(myFile, 14)
    'DateCréation = myFolder.GetDetailsOf(myFile,3)
    'auteur = myFolder.GetDetailsOf(myFile,9)
    'titre = myFolder.GetDetailsOf(myFile,10)
    tmp = LCase(Left(nf, Len(nf) - 4))
    mondico.Item(tmp) = tmp
    If cmt <> "" Then
      b = Split(cmt, ",")
      For Each k In b
        tmp = LCase(k)
        mondico.Item(tmp) = tmp
      Next k
    End If
    nf = Dir
  Loop
  temp = mondico.items
  Call tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
  [A2:B100].ClearContents
  For Each s In ActiveSheet.Shapes
     If Not Intersect(s.TopLeftCell, Range("c:c")) Is Nothing Then s.Delete
  Next s
  ligne = 2
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoireImages)
  nf = Dir(repertoireImages & "*.jpg")
  Do While nf <> ""
    Set myFile = myFolder.items.Item(nf)
    cmt = myFolder.GetDetailsOf(myFile, 14)
    If InStr(LCase(cmt), Trim(Me.ComboBox1)) > 0 Or LCase(Left(nf, Len(nf) - 4)) = Me.ComboBox1 Then
      Cells(ligne, 1) = nf
      Cells(ligne, 2) = cmt
      Set s = ActiveSheet.Pictures.Insert(repertoireImages & nf)
      H = s.Height
      L = s.Width
      s.Name = nf
      s.Left = Cells(ligne, 3).Left + 2
      s.Top = Cells(ligne, 3).Top + 2
      s.Height = Cells(ligne, 1).EntireRow.RowHeight - 3
      ech = s.Height / H
      s.Width = L * ech - 3
     ligne = ligne + 1
   End If
   nf = Dir
  Loop
End Sub

Sub tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi)
   If gauc < d Then Call tri(a, gauc, d)
End Sub

Survol d'une image

On affiche 'une image au survol d'une image.

SurvolImage

-Avec la BO Boite à outils contrôle, créer une image Image1
-Dans les propriétes, choisir l'image dans Picture
-Inserer une image Image2

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
    ActiveSheet.Shapes("Image2").Visible = False
  Else
   ActiveSheet.Shapes("Image2").Visible = True
  End If
End Sub

Inversion d'image au survol

ImageInterneSurvol

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Image1.Picture = _
  IIf((X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10), Sheets("photos").Image1.Picture,       Sheets("photos").Image2.Picture)
End Sub

FormImageInterneSurvol
FormImageExterneSurvol
ImageExterneSurvol

Diaporama

Les photos sont encapsulées dans des objets Contrôle Image (BO contrôles).

DiaporamaTableurPhotosInternes

Dim p, temps, f
Sub auto_open()
  Set f = Sheets("photos")
  p = 1
  majHeure
End Sub

Sub majHeure()
  temp = "Photo" & p
  Sheets("accueil").Image1.Picture = f.OLEObjects(temp).Object.Picture
  p = p + 1
  If p = 4 Then p = 1
  temps = Now + TimeValue("00:00:3")
  Application.OnTime temps, "majHeure"
End Sub

Sub auto_close()
   On Error Resume Next
   Application.OnTime temps, Procedure:="majHeure", Schedule:=False
End Sub

Dans un formulaire

DiaporamaFormPhotosInternes

Autres versions

DiaporamaTableurPhotosInternes
DiaporamaTableurPhotosInternes2
DiaporamaTableurPhotosExternes
DiaporamaFormulaire

Diaporama de 3 champs d'un classeur

-Créer 3 photos des champs A1:E7 des feuilles 2008,2009,2010 avec Edition/Copier puis Maj+Edition/coller l'image avec liaison
-Les nommer 2008,2009,2010

DiaporamaChamp

Dim temps, p
  Sub auto_open()
  majHeure
  p = 0
End Sub

Sub majHeure()
  Application.ScreenUpdating = False
  a = Array(2008, 2009, 2010)
  For Each c In a
    Sheets(1).Shapes(CStr(c)).Visible = False
  Next c
  Sheets(1).Shapes(CStr(a(p))).Left = 20
  Sheets(1).Shapes(CStr(a(p))).Top = 10
  Sheets(1).Shapes(CStr(a(p))).Visible = True
  p = p + 1
  If p > UBound(a) Then p = 0
  temps = Now + TimeValue("00:00:5")
  Application.OnTime temps, "majHeure"
End Sub

Sub auto_close()
  On Error Resume Next
  Application.OnTime temps, Procedure:="majHeure", Schedule:=False
End Sub

Affichage d'une image interne dans un formulaire

En mode direct

Pour copier une image interne dans un contrôle image d'un formulaire, Edition/Copier puis dans la propriété Picture du contrôle Edition/Coller.

En VBA

Form Image Interne
Form Image Interne Stephen Bullen

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
    Me.ComboBox1.AddItem s.Name
  Next
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.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
End Sub

Autre solution

Les images sont encapsulées dans des contrôles Image

FormImageInterne3

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
     Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_Change()
  temp = Me.ComboBox1
  Me.Image1.Picture = f.OLEObjects(temp).Object.Picture
End Sub

Affichage d'images internes dans un cadre

On affiche une image interne dans une une autre image (cadre)

PhotoInterneCadre
PhotoInterneCadre2

Dim p
Private Sub CommandButton1_Click()
  Set f = Sheets("photos")
  p = p + 1: If p > f.Shapes.Count Then p = 1
  Set s = f.Shapes("photo" & p)
  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
 ActiveSheet.Shapes("Cadre").Fill.UserPicture "monimage.jpg"
  Kill "monimage.jpg"
End Sub

Fonction d'affichage d'une image interne

Cette fonction affichePhoto(photo As String, nom As String) affiche une image interne de la personne en B2. Les images sont encapsulées dans des contrôles Image (Boite à outils contrôles)

FonctionAffichePhotoInterne

Function affichePhoto(Photo As String, nom As String)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.OLEObjects(Photo).Object.Picture = Nothing
  f.OLEObjects(Photo).Object.Picture = Sheets("images").OLEObjects(nom).Object.Picture
  affichePhoto = ""
End Function

Autre exemple

Cette fonction affichePhoto(photo As String, nom As String) affiche une image interne de la personne qui a réalisé le meilleur CA du mois.

FonctionAffichePhotoInterne

En B7:=affichePhoto(B1;INDEX($A$2:$A$6;EQUIV(MAX(B2:B6);B2:B6;0)))

Function affichePhoto(photo As String, nom As String)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.OLEObjects(Photo).Object.Picture = Nothing
  f.OLEObjects(photo).Object.Picture = Sheets("images").OLEObjects(nom).Object.Picture
  affichePhoto = nom
End Function

Autre exemple

L'image du bouton à bascule est modifiée lorsque le bouton est enfoncé.

ToggleYesNo

Private Sub ToggleButton1_Click()
  Me.ToggleButton1.Picture = IIf(Me.ToggleButton1, Me.Image1.Picture, Me.Image2.Picture)
End Sub

Affiche une photo externe dans un formulaire au survol d'une cellule du champ B2:B10

-Nommer le champ B2:B10 (champ)
-Avec la boîte à outils Contrôles, créer un label Label1 transparent avec A
-Le positionner sur le champ.

AffichePhotoExterneSurvolCellule

Dim Xc, Yc
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
     Range("champ").Interior.ColorIndex = xlNone
     UserForm1.Hide
   Else
     Hcel = Range("champ").Cells(1, 1).Height
     Lcel = Range("champ").Cells(1, 1).Width
     Yc = Int(Y / Hcel)
     Xc = Int(X / Lcel)
     Range("champ").Interior.ColorIndex = xlNone
     Range("champ").Cells(1, 1).Offset(Yc, Xc).Interior.ColorIndex = 3
     'Range("champ").Cells(1, 1).Offset(Yc, Xc).Select ' optionel
     répertoireImage = "c:\mesdoc" ' à adapter
     NomImage = Range("champ").Cells(1, 1).Offset(Yc, Xc)
     If Dir(répertoireImage & "\" & NomImage & ".jpg") <> "" Then
       UserForm1.Image1.Picture = LoadPicture(répertoireImage & "\" & NomImage & ".jpg")
       UserForm1.Show
     End If
  End If
End Sub

Private Sub Label1_Click()
   Range("champ").Interior.ColorIndex = xlNone
   Range("champ").Cells(1, 1).Offset(Yc, Xc).Select
   Range("champ").Cells(1, 1).Offset(Yc, Xc).Interior.ColorIndex = 4
   ActiveSheet.Label1.Visible = False
   Range("champ").Cells(1, 1).Offset(Yc, Xc).Select
   AppActivate "Microsoft Excel"
   ActiveSheet.Label1.Width = Range("champ").Width
   ActiveSheet.Label1.Height = Range("champ").Height
   ActiveSheet.Shapes("label1").Top = Range("champ").Top + 1
   ActiveSheet.Shapes("label1").Left = Range("champ").Left + 1
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Intersect([champ], Target) Is Nothing Then
    Unload UserForm1
    Range("champ").Interior.ColorIndex = xlNone
    ActiveSheet.Label1.Visible = True
  Else
    Range("champ").Interior.ColorIndex = xlNone
    ActiveSheet.Label1.Visible = True
  End If
End Sub

Tableau avec arrière plan

Pour obtenir un tableau avec arrière-plan:

Tableau Arrière Plan

Solution1

1-Créer un rectangle avec les formes automatiques
2-Format/Forme automatique
3-Transparence 65%
3-Couleurs et traits/Couleur/Motifs et textures/Image
4-Choisir une image
5- Déplacer le rectangle sur le tableau

Solution2

Pour automatiser le procédé ci dessus, créer une fonction ArrierePlan(NomImage,ChampArrierePlan,RépertoireImage,transparence)

En H1 par ex: =ArrierePlan("clown";B1:F10;"c:\mesdoc\";70%)

Tableau Arrière Plan
Tableau Arrière PlanURL

Solution3

1-Edition/copier du champ B2:F6
2-Maj+Edition/coller image avec liaison
3-Agrandir la copie
4- Affecter une image d'arrière plan:
-Format/image
-Couleurs et traits/couleur
-Motifs et textures/image

Fonction d'affichage d'une jauge sur un champ en fonction d'un taux de réalisation

La fonction Jauge(taux, champJauge As Range,Largeur,Transparence) crée sur le champ spécifié un shape proportionnel au taux de réalisation (0%->100%)

FonctionJaugeVerticale
FonctionJaugeVerticale2
FonctionJaugeHorizontale
FonctionJaugeHorizontale2

Pour obtenir une jauge sur 40% de la largeur de colonne et non transparente.

En B12:=jauge(B11/B2;B4:B9;40%;0)

Pour obtenir une jauge sur la largeur de la colonne et transparente à 70%.

En B12:=jauge(B11/B2;B4:B9;100%;70%)

        

Function Jauge(taux, champJauge As Range, largeur, transparence)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  NomShape = "S" & Application.Caller.Address
  NomShape2 = NomShape & "-x"
  For Each s In f.Shapes
    If s.Type = 1 Then
       If Not Intersect(s.TopLeftCell, champJauge) Is Nothing Then
         If Right(s.Name, 2) = "-x" Then temp = Left(s.Name, Len(s.Name) - 2) Else temp = s.Name
         If UCase(temp) <> UCase(NomShape) Then s.Delete
      End If
    End If
  Next s
  For Each s In f.Shapes
     If UCase(s.Name) = UCase(NomShape) Then ok = True
  Next s
  If Not ok Then
    f.Shapes.AddShape(msoShapeRectangle, 120#, 258.75, 52.5, 34.5).Name = NomShape
    f.Shapes(NomShape).Fill.ForeColor.SchemeColor = 9
    NomShape2 = NomShape & "-x"
    f.Shapes.AddShape(msoShapeRectangle, 120#, 258.75, 52.5, 34.5).Name = NomShape2
  End If
  If taux > 1 Then taux = 1
  f.Shapes(NomShape2).Fill.ForeColor.SchemeColor = IIf(taux < 0.5, 2, 3)
  f.Shapes(NomShape).Fill.Transparency = transparence
  f.Shapes(NomShape).Width = champJauge.Width * largeur
  f.Shapes(NomShape).Height = champJauge.Height * (1 - taux)
  f.Shapes(NomShape).Top = champJauge.Top
  f.Shapes(NomShape).Left = champJauge.Left

  f.Shapes(NomShape2).Fill.Transparency = transparence
  f.Shapes(NomShape2).Width = champJauge.Width * largeur
  f.Shapes(NomShape2).Height = champJauge.Height * taux
  f.Shapes(NomShape2).Top = champJauge.Top + champJauge.Height * (1 - taux)
  f.Shapes(NomShape2).Left = champJauge.Left
  Jauge = ""
End Function

Avec =jauge(B10/B2;B10;40%;0), on obtient

FonctionJauge2

Si le champ qui recoit la jauge contient des cellules fusionnées remplacer champ.Height par champJauge.MergeArea.Height.

Fonction jaugeTriangle(Taux;ChampJauge)

En B11: =jaugeTriangle(B10/B2;B4:B9)

FonctionJaugeTriangle

=jaugeThermo(taux;champ)

Fonction Jauge Thermo

=Thermo(taux;champ;largeur%)

Fonction Jauge Thermo2

Fonction Jauge(taux, champJauge As Range, hauteur)

JaugeCompteur

     

Modification de la transparence de shapes 

Ci dessous, le shape nommé Dupont apparaît plus ou moins foncé en fonction du % total/objectif en B12.
Ceci est obtenu en modifiant la transparence (40% -->100%)

TransparenceCA

Private Sub Worksheet_Calculate()
  ActiveSheet.Shapes("dupont").Fill.Transparency = 1 - (100 * IIf([B12] < 1, [B12], 1)) / 170
End Sub

La fonction Transparent(nomShape, cellule, taux) modifie la transparence de shapes en fonction de la valeur de la cellule par rapport au maximun des cellules du champ B11:F11.
Si le shape n'existe pas, il est crée et positionné par la fonction.

Transparence
Transparence2

Function Transparent(NomShape, cel, taux)
  Set f = Sheets(Application.Caller.Parent.Name)
  For Each s In f.Shapes
    If s.Type = 17 Then
      If s.TopLeftCell.Address = cel.Address Then
        If UCase(s.Name) <> UCase(NomShape) Then s.Delete
      End If
    End If
  Next s
  For Each s In f.Shapes
    If UCase(s.Name) = UCase(NomShape) Then ok = True
  Next s
  If Not ok Then
    f.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50).Name = NomShape
    f.Shapes(NomShape).Fill.ForeColor.SchemeColor = 2 '3=vert 4:bleu 13:jaune 2:rouge
  End If
  f.Shapes(NomShape).Fill.Transparency = 1 - (100 * taux) / 170
  f.Shapes(NomShape).Width = cel.Width
  f.Shapes(NomShape).Height = cel.Height
  f.Shapes(NomShape).Top = cel.Top
  f.Shapes(NomShape).Left = cel.Left
  Transparent = ""
End Function

Transparence et couleur d'un shape en fonction du % Objectif/Réalisé

En B13:
=SI(B12<100%;Transparent(B1;B12;B12;2);Transparent(B1;B12;100%;3))

Transparence3

Transparence, couleur et forme d'un shape en fonction du % Total/an-1

-Pour les % positifs, un shape FlècheHaut vert est affiché.
-Pour les % négatifs, un shape FlècheBas vert est affiché.
-
La transparence est fonction de la valeur du pourcentage.

En B13: =SI(B12>0;Transparent(B1;B12;B12;3;100%);Transparent(B1;B12;B12;2;100%))

Pour afficher les flèches sur le champ B4:B9 sur la moitié de la colonne:

En B13: =SI(B12>0;Transparent(B1;B4:B9;B12;3;50%);Transparent(B1;B4:B9;B12;2;50%))

Transparence4

    

Le dégradé du % de chaque produit dépend du pourcentage maximum (20% sur l'exemple)

FonctionFlèche

Fonction d'affichage d'un shape & d'un message

Cette fonction Affiche(NomShape;couleur;message) crée un shape dans la cellule où est elle est écrite et afiiche un message.

Fonction AfficheMessage

En B11:
=SI(B10>300;Affiche(B1;2;"Excellent!");SI(B10>200;Affiche(B1;3;"Super!");SI(B10>100;Affiche(B1;5;"Bravo!");Affiche(B1;9;""))))

Fonction d'affichage d'une image d'arrière-plan dans un champ

Cette fonction =ArrierePlan(NomPhoto;ChampArrièrePlan;RépertoirePhoto) crée un shape et le positionne sur le champ spécifié.

-Pour déplacer les shapes, cliquer dessus
-F9 pour les replacer sur le champ

Fonction Arrière-Plan
Arrière-PlanVariable

En B12:
=ArrierePlan(B1;B4:B9;"c:\mesdoc\")

Arrière-plan variable en fonction du mois

Arrière-PlanVariable

Construction de flèches

ConstructionFlèches

Construction de feux tricolores

Cette fonction Feu(NomFeu, Pourc, champAffFeu) construit des feux tricolores en fonction d'un % et les affiche à l'endroit spécifié.

-Rouge si %<0
-Orange si %=0
-Vert si %>0

ConstructionFeux

Variantes de cette fonction
Function FeuTranche(NomFeu, Pourc, pRouge, pOrange, champAffFeu)
Function FeuNo(NomFeu, no, champAffFeu)

Function Feu(NomFeu, Pourc, champAffFeu)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  If Pourc < 0 Then no = 1 Else If Pourc = 0 Then no = 2 Else no = 3
  For Each s In f.Shapes
    If s.Type = 1 Then
      If Not Intersect(s.TopLeftCell, champAffFeu.Resize(2)) Is Nothing Then
         If Mid(s.Name, Len(NomFeu) + 1, 1) = "C" Then
           temp = Left(s.Name, Len(s.Name) - 2)
         Else
           temp = s.Name
         End If
         If UCase(temp) <> UCase(NomFeu) Then s.Delete
       End If
    End If
  Next s
  For Each s In f.Shapes
     If UCase(s.Name) = UCase(NomFeu) Then ok = True
  Next s
  If Not ok Then
    f.Shapes.AddShape(msoShapeRectangle, 15, 15, 16, 48).Name = NomFeu
    f.Shapes(NomFeu).Fill.ForeColor.SchemeColor = 0
    For c = 1 To 3
      f.Shapes.AddShape(msoShapeOval, 15 + 3 * (c - 1) * 15, 15 + 3, 10, 10).Name = NomFeu & "C" & c
    Next
  End If
  f.Shapes(NomFeu).Top = champAffFeu.Top + 2
  f.Shapes(NomFeu).Left = champAffFeu.Left + 5
  For c = 1 To 3
    f.Shapes(NomFeu & "C" & c).Top = champAffFeu.Top + (c - 1) * 15 + 6
    f.Shapes(NomFeu & "C" & c).Left = champAffFeu.Left + 8
    f.Shapes(NomFeu & "C" & c).Fill.ForeColor.SchemeColor = 0
    f.Shapes(NomFeu & "C" & c).Line.Visible = True
    f.Shapes(NomFeu & "C" & c).Line.ForeColor.SchemeColor = 1
  Next c
  f.Shapes(NomFeu & "C" & no).Fill.ForeColor.SchemeColor = Array(2, 52, 3)(no - 1)
  Feu = ""
End Function

Noms de champ dans shape

Crée des shapes avec les noms de champ de la feuille.

NomsChampShape

Sub NomsChamps()
  For Each s In ActiveSheet.Shapes
     If Left(s.Name, 2) = "x_" Then s.Delete
  Next s
  For Each n In ActiveWorkbook.Names
      p = InStr(n, ActiveSheet.Name)
      If p > 0 Then
        p1 = InStr(n, "!")
        P2 = InStr(n, ":")
        c = Mid(n, p1 + 1, P2 - p1 - 1)
        nom = "x_" & n.Name
        ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, Len(n.Name) * 7, 10).Name = nom
        ActiveSheet.Shapes(nom).TextFrame.Characters.Font.Name = "Verdana"
        ActiveSheet.Shapes(nom).TextFrame.Characters.Font.Size = 8
        ActiveSheet.Shapes(nom).Fill.ForeColor.SchemeColor = 13
        ActiveSheet.Shapes(nom).Left = Range(c).Left
        t = IIf(Range(c).Row > 1, Range(c).Offset(-1, 0).Top, Range(c).Top)
        ActiveSheet.Shapes(nom).Top = t
        ActiveSheet.Shapes(nom).TextFrame.Characters.Text = n.Name
     End If
    Next n
End Sub

Choix du champ à visualiser

-Créer 3 photos des champs A1:E7 des feuilles 2008,2009,2010 avec Edition/Copier puis Maj+Edition/coller l'image avec liaison
-Les nommer 2008,2009,2010

ChoixChamp

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set champ = [B2:B4]
  If Not Intersect(champ, Target) Is Nothing And Target.Count = 1 Then
     For Each c In champ
       ActiveSheet.Shapes(CStr(c)).Visible = False
     Next c
     If Target <> "" Then
       ActiveSheet.Shapes(CStr(Target)).Left = 180
       ActiveSheet.Shapes(CStr(Target)).Top = 10
       ActiveSheet.Shapes(CStr(Target)).Visible = True
     End If
   End If
End Sub

Déplacement d'un shape avec le curseur

La photo du champ A1:F7 de feuil1 suit le curseur lorsque celui ci est déplacé

Pour créer une photo du champ A1:E7 de feuil1:

-Edition/Copier du champ
-MaJ+Edition coller l'image avec liaison dans Feuil2
-Nommer le shape Image 1

Pour que la photo Image 1 du champ suive le déplacement du curseur

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Shapes("image 1").Top = Target.Top
  Shapes("image 1").Left = Target.Offset(, 2).Left
End Sub

ChampCurseur

Pour un affichage en haut à gauche de l'écran.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Shapes("image 1").Top = ActiveWindow.VisibleRange.Rows(1).Top
  Shapes("image 1").Left = ActiveWindow.VisibleRange.Columns(1).Left
End Sub

Conversion de photos en commentaire vers des fichiers JPG

ConvCmtJPG

Sub ExtraitPhotoCmtJPG()
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
     c.Comment.Visible = True
     H = c.Comment.Shape.Height
     L = c.Comment.Shape.Width
     c.Comment.Shape.CopyPicture
     c.Comment.Visible = False
     f.ChartObjects.Add(0, 0, L, H).Chart.Paste
     f.ChartObjects(1).Border.LineStyle = 0
     f.ChartObjects(1).Chart.Export Filename:= _
       répertoirePhotos & c & ".jpg", FilterName:="jpg"
     f.ChartObjects(1).Delete
   Next c
End Sub

Conversion de photos en commentaire vers des images internes

ConvCmtImages

Sub ExtraitPhotosCmt()
  Set f = Sheets("extrait")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    c.Comment.Visible = True
    c.Comment.Shape.CopyPicture
    c.Comment.Visible = False
    f.Paste
    Selection.Name = c.Value
  Next c
End Sub

Conversion d'images internes en JPG

ConvImagesJPG

Sub ConvShapesJPG()
  répertoirePhotos = "c:\photos\"
  Set f = Sheets("images")
  For Each s In f.Shapes
    If s.Type = 13 Then
     s.CopyPicture
     f.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
     f.ChartObjects(1).Select
     Selection.Border.LineStyle = 0
     f.ChartObjects(1).Chart.Export Filename:=répertoirePhotos & s.Name & ".jpg"
     f.ChartObjects(1).Delete
   End If
 Next s
End Sub

Choix d'une photo interne dans un listbox photo

-Les photos internes sont dans la feuille Liste
-Elles sont d'abord exportées dans un répertoire c:\photos par auto_open()

ChoixPhotoInterneListBox

Dim répertoirePhotos
Sub auto_open()
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("liste")
    lig = [liste].Find(c, LookAt:=xlWhole).Row
    col = [liste].Column + 1
    For Each s In f.Shapes
      If s.TopLeftCell.Address = Cells(lig, col).Address Then
        H = s.Height
        L = s.Width
        s.Copy
        f.ChartObjects.Add(0, 0, L, H).Chart.Paste
        f.ChartObjects(1).Border.LineStyle = 0
        f.ChartObjects(1).Chart.Export Filename:= _
        répertoirePhotos & c & ".jpg", FilterName:="jpg"
        f.ChartObjects(1).Delete
      End If
    Next s
  Next c
  UserForm1.Show
End Sub

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhotos
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhotos = "c:\photos\" ' Adapter
  For i = 1 To n
    Me("Image" & i).Picture = LoadPicture(répertoirePhotos & Range("liste").Cells(i + début - 1, 1) & ".jpg")
    Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
    Me("Image" & i).BorderStyle = 0
    Me("Label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
début = ScrollBar1
affiche
End Sub

Sub ChoixClick(p, nom)
  For i = 1 To n
    Me("Image" & i).BorderStyle = 0
  Next i
  Me("Image" & p).BorderStyle = 1
  If ActiveCell.Column = 3 Then
    ActiveCell.Offset(, -1) = nom
    For Each s In ActiveSheet.Shapes
     If Not Intersect(s.TopLeftCell, ActiveCell) Is Nothing Then s.Delete
    Next s
    Set Img = ActiveSheet.Pictures.Insert(répertoirePhotos & nom & ".jpg")
    Img.Left = ActiveCell.Left
    Img.Top = ActiveCell.Top
  End If
End Sub

Private Sub Image1_Click()
  ChoixClick 1, Me.Image1.ControlTipText
End Sub

Private Sub Image2_Click()
  ChoixClick 2, Me.Image2.ControlTipText
End Sub

Private Sub Image3_Click()
  ChoixClick 3, Me.Image3.ControlTipText
End Sub

Les photos sont dans des commentaires

ChoixPhotoCmtListBoxCmt

Les photos des commentaires sont exportées sous forme de JPG dans le répertoire c:\photos\

Sub auto_open()
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    c.Comment.Visible = True
    H = c.Comment.Shape.Height
    L = c.Comment.Shape.Width
    c.Comment.Shape.CopyPicture
    c.Comment.Visible = False
    f.ChartObjects.Add(0, 0, L, H).Chart.Paste
    f.ChartObjects(1).Border.LineStyle = 0
    f.ChartObjects(1).Chart.Export Filename:= _
    répertoirePhotos & c & ".jpg", FilterName:="jpg"
    f.ChartObjects(1).Delete
  Next c
  UserForm1.Show
End Sub

Code du formulaire

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhoto
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [Liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhotos = "c:\photos\" ' Adapter
  For i = 1 To n
    Me("Image" & i).Picture = LoadPicture(répertoirePhotos & Range("liste").Cells(i + début - 1, 1) & ".jpg")
    Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
    Me("Image" & i).BorderStyle = 0
    Me("Label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Sub ChoixClick(p, nom)
  For i = 1 To n
    Me("Image" & i).BorderStyle = 0
  Next i
  Me("Image" & p).BorderStyle = 1
  ActiveCell = nom
  [Liste].Find(nom, LookAt:=xlWhole).Copy
  ActiveCell.PasteSpecial Paste:=xlPasteFormats
  ActiveCell.PasteSpecial Paste:=xlPasteComments
End Sub

Private Sub Image1_Click()
  ChoixClick 1, Me.Image1.ControlTipText
End Sub

Private Sub Image2_Click()
  ChoixClick 2, Me.Image2.ControlTipText
End Sub

Private Sub Image3_Click()
   ChoixClick 3, Me.Image3.ControlTipText
End Sub

Private Sub Label1_Click()
  ChoixClick 1, Me.Label1.Caption
End Sub

Private Sub Label2_Click()
  ChoixClick 2, Me.Label2.Caption
End Sub

Private Sub Label3_Click()
  ChoixClick 3, Me.Label3.Caption
End Sub

Choix d'une photo externe dans un listbox photo

ChoixPhotoExterneListBox
ChoixPhotoExterneListBoxCmt

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhoto
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [Liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhoto = "c:\mesdoc\" ' Adapter
  For i = 1 To n
    Me("Image" & i).Picture = LoadPicture(répertoirePhoto & Range("liste").Cells(i + début - 1, 1) & ".jpg")
    Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
    Me("Image" & i).BorderStyle = 0
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Private Sub Image1_Click()
  ChoixClick 1
End Sub

Private Sub Image2_Click()
 ChoixClick 2
End Sub

Private Sub Image3_Click()
 ChoixClick 3
End Sub

Sub ChoixClick(p)
  For i = 1 To n
    Me("Image" & i).BorderStyle = 0
  Next i
  Me("Image" & p).BorderStyle = 1
  If ActiveCell.Column = 3 Then
    nom = Me("image" & p).ControlTipText
    ActiveCell.Offset(, -1) = nom
    Set Img = ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg")
    Img.Left = ActiveCell.Left
    Img.Top = ActiveCell.Top
  End If
End Sub

Copie chaque image dans l'onglet associé au nom

InsertionImage

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
  Set f = Sheets("Dossier images")
  If UCase(Sh.Name) <> UCase(f.Name) Then
    nom = Sheets(Sh.Name).[B1]
    For Each s In Sheets(Sh.Name).Shapes
        If UCase(s.Name) = UCase(nom) Then existe = True
    Next s
    If Not existe Then
    Set adr = f.[2:2].Find(nom, LookAt:=xlWhole)
    If Not adr Is Nothing Then
      col = adr.Column
      For Each s In f.Shapes
         If s.TopLeftCell.Address = f.Cells(1, col).Address Then
            Sheets(Sh.Name).[A1].Select
            s.Copy
            Sheets(Sh.Name).Paste
            Selection.Name = nom
            Selection.Left = Sheets(Sh.Name).[A1].Left + 5
            Selection.Top = Sheets(Sh.Name).[A1].Top + 5
          End If
        Next s
      End If
    End If
  End If
End Sub

Affiche les images filtrées

FiltreAutoShape

Function affiche(champ As Range)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  For Each s In f.Shapes
    If UCase(Left(s.Name, 3)) = "IMG" Then s.Visible = False
  Next
  For Each c In champ
    On Error Resume Next
    If Not c.EntireRow.Hidden Then f.Shapes("img" & c.Value).Visible = True
  Next c
  affiche = ""
End Function

Création de flèches pour données/validation/liste

DVListeFlèche3

Sub CréeFlèches()
  ActiveSheet.Shapes.AddShape(7, 6, 6, 6, 6).Name = "Flèche"
  ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 11, 10).Name = "Rect"
  ActiveSheet.Shapes("Flèche").Fill.ForeColor.SchemeColor = 0
  ActiveSheet.Shapes("Rect").Fill.ForeColor.SchemeColor = 22
  ActiveSheet.Shapes("Flèche").IncrementRotation 180
  ActiveSheet.Shapes("Flèche").Line.Visible = msoFalse
  ActiveSheet.Shapes("Rect").Line.Visible = msoFalse
  For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
    ActiveSheet.Shapes("Rect").Copy
    c.Offset(, 1).Select
    ActiveSheet.Paste
    Selection.Name = c.Address & "x"
    Selection.Left = c.Offset(, 1).Left + 2
    Selection.Top = c.Offset(, 1).Top + 1
    Selection.Height = c.Offset(, 1).Height - 1
    Selection.OnAction = "clicFlèche"
    ActiveSheet.Shapes("flèche").Copy
    c.Offset(, 1).Select
    ActiveSheet.Paste
    Selection.Name = c.Address
    Selection.Left = c.Offset(, 1).Left + 4
    Selection.Top = c.Offset(, 1).Top + 3
    Selection.Height = c.Offset(, 1).Height - 7
    Selection.OnAction = "clicFlèche"
  Next c
  ActiveSheet.Shapes("flèche").Delete
  ActiveSheet.Shapes("rect").Delete
End Sub

Sub ClicFlèche()
  Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Offset(, -1).Select
  SendKeys "%{down}"
End Sub

Classement avec images

Dans un onglet Classement, on récupère les informations de la feuille BD dans l'ordre décroissant des points avec les formules.

En D2:=SI(LIGNES($1:1)<=NBVAL(Noms);GRANDE.VALEUR(points;LIGNES($1:1));0)

En B2:=SI(LIGNES($1:1)<=NBVAL(Noms);
INDEX(Noms;PETITE.VALEUR(SI(points=D2;LIGNE(INDIRECT("1:"&LIGNES(Noms))));NB.SI(D$2:D2;D2)));"")

Pour récupérer les images de la feuille BD.

TriImages

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = flase
  For Each s In ActiveSheet.Shapes
    If s.Type = 13 Then s.Delete
  Next s
  For Each c In [B2:B20]
     If c <> "" Then
       lig = [noms].Find(c, LookAt:=xlWhole).Row
       col = [noms].Column + 1
       For Each s In Sheets("bd").Shapes
         If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
      Next s
      ActiveSheet.Paste
      Selection.ShapeRange.Left = c.Offset(, 1).Left + 7
      Selection.ShapeRange.Top = c.Top + 5
    End If
  Next c
End Sub

Inverse Gras/Maigre

InverseGras

Sub appel()
  NomShape = Application.Caller
  ActiveSheet.Shapes(NomShape).TextFrame.Characters(Start:=1, Length:=15).Font.Bold = _
    Not ActiveSheet.Shapes(NomShape).TextFrame.Characters(Start:=1, Length:=1).Font.Bold
End Sub

Filtre lettre

Met en gras et en couleur le bouton appelant

FiltreLettre

Sub appelBoutons2()
  For Each c In ActiveSheet.Shapes
     If c.Type = 8 And Left(c.Name, 4) <> "Drop" Then
      c.TextFrame.Characters(Start:=1, Length:=1).Font.Bold = False
      c.TextFrame.Characters(Start:=1, Length:=1).Font.ColorIndex = 0
    End If
  Next c
  nomshape = Application.Caller
  '[A1] = ActiveSheet.Shapes(nomshape).TextFrame.Characters.Text
  ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.Bold = True
  ActiveSheet.Shapes(nomshape).TextFrame.Characters(Start:=1, Length:=1).Font.ColorIndex = 3
  '--- Filtre
  lettre = ActiveSheet.Shapes(nomshape).TextFrame.Characters.Text
  critère = "=" & lettre & "*"
  Range("B4").Select
  Selection.AutoFilter Field:=1, Criteria1:=critère
End Sub

Nom de l'image d'une cellule

NomImgCel

Sub essai()
  MsgBox NomImgCel(Range("C3"), "feuil1")
  MsgBox NomImgCel(Range("A1"), "feuil1")
End Sub

Function NomImgCel(ByVal c As Range, f)
  NomImgCel = ""
  For Each s In Sheets(f).Shapes
    If s.TopLeftCell.Address = c.Address Then NomImgCel = s.Name
  Next s
End Function

Création de shapes boutons

CréationShapesBoutons

Fonction CouleurImage()

Donne la couleur d'une image.

FonctionCouleurImage

Function couleurImage(s)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  couleurImage = f.Shapes(s).Fill.ForeColor.RGB
End Function

Colorier un shape en fonction d'une valeur

En fonction du total en B8, on colorie l'image ZT1

-Au dessus de 500 -> Vert
-Entre 250 et 500 -> Orange
-Moins de 250 -> Rouge

=ColorieImage("ZT1";SI(B8>500;65025;SI(B8>250;4626167;255)))

Function ColorieImage(s, couleur)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.Shapes(s).Fill.ForeColor.RGB = couleur
End Function

Colorier Image
Colorier Image3
Colorier Image3B

Colorier des indicateurs

Indicateur
Indicateur Image autre feuille

Colorier Indicateurs
Colorier Indicateurs2
Colorier Croix

Modifier le texte d'un shape

=modifietexte("monimage";B15)

Function modifieTexte(nomImage, libellé)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.Shapes(nomImage).TextFrame.Characters.Text = libellé
  modifieTexte = ""
End Function

Colorier un shape avec la couleur d'une cellule

Colorier Image Couleur Cellule

Function ColorieImage(s, couleur)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.Shapes(s).Fill.ForeColor.RGB = couleur
End Function

Function CouleurCellule(c As Range)
  Application.Volatile
  CouleurCellule = c.Interior.Color
End Function

Colorier un shape avec la couleur d'un shape

Sur l'exemple ci dessous, on colorie des shapes avec la couleur d'un autre shape.

Colorier Image Couleur Shape

=colorieimage("MonTriangle";couleurimage("monshape"))

Function ColorieImage(s, couleur)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  f.Shapes(s).Fill.ForeColor.RGB = couleur
End Function

Function couleurImage(s)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  couleurImage = f.Shapes(s).Fill.ForeColor.RGB
End Function

Colorier Image Couleur Cellule2


Sur cette version, le coloriage des états se fait en fonction du CA.

Colorier Shape Couleur CA

Carte de France des départements & des régions (colorier des départements & régions)

Pour colorier les départements en fonction du CA:

Colorier Carte France CA
Colorier Carte France Nom CA
Colorier Carte France Nom Responsables
Colorier Carte France Clic
Colorier Carte France CA Fonction
Colorier Carte des Régions

Sub coloriage()
  For Each c In [départ]
    If c <> "" Then
      ca = c.Offset(, 1)
      p = Application.Match(ca, [légende], 1)
      couleur = Range("légende").Cells(p, 1).Interior.Color
      ActiveSheet.Shapes("fr-" & c).Fill.ForeColor.RGB = couleur
   End If
  Next c
End Sub

Pour écrire les numéros de département:

Sub EcritNoDepart()
  For Each c In [départ]
    If c <> "" Then ecritShape "fr-" & c, c
  Next c
  c = "54": ecritShape "fr-" & c, c, "Bas"
  c = "192": ecritShape "fr-" & c, Right(c, 2), , "Gauche"
  For Each c In Array("175", "193", "194")
    ecritShape "fr-" & c, Right(c, 2)
  Next c
End Sub

Pour obtenir des infos-bulles au survol des départements:

Sub bulles()
  For Each s In ActiveSheet.Shapes
   If s.Type <> 8 Then
     ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
     tmp = Mid(s.Name, 4)
     bulle = Application.VLookup(tmp, [departca], 2, False)
     If Not IsError(bulle) Then
       libdep = Application.VLookup(tmp, [departca], 3, False)
       s.Hyperlink.ScreenTip = libdep & " Ca:" & Format(bulle, "# ##0") & Chr(10)
     Else
       s.Hyperlink.ScreenTip = "...."
     End If
   End If
  Next s
End Sub

Pour déclencher une macro sur le clic d'un shape:

Sub GenereOnAction()
  For Each c In [départ]
    If c <> "" Then ActiveSheet.Shapes("fr-" & c).OnAction = "ClicDepart"
  Next c
End Sub

Sub clicDepart()
  dep = Mid(Application.Caller, 4)
  [i2] = Application.VLookup(dep, [départca], 3, False)
  [j2] = Format(Application.VLookup(dep, [départca], 2, False), "##,0")
End Sub

Pour grouper/dégrouper les shapes

Sub grouperShapes()
  Dim a(), i
  For Each s In ActiveSheet.Shapes
     If s.Type = 5 Then
        i = i + 1: ReDim Preserve a(1 To i): a(i) = s.Name
     End If
   Next
   ActiveSheet.Shapes.Range(a).Group.Name = "CarteFrance"
End Sub

Sub degrouperShapes()
  ActiveSheet.Shapes("CarteFrance").Ungroup
End Sub

Colorier la carte de l'Europe

Colorier Carte Europe
Colorier Carte Europe 2
Colorier Carte Europe 3
Colorier Carte Belgique

Colorier la carte du Monde

Le pays cherché est choisi dans un menu déroulant. Le pays choisi est colorié en rouge.
Des Info-Bulles (nom du pays) apparaissent au survol de chaque pays.

Sub Info_bulles()
  For Each c In [Pays]
    ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(c), Address:="", SubAddress:=""
    ActiveSheet.Shapes(c).Hyperlink.ScreenTip = c
  Next c
End Sub

Colorier Carte Monde

-Avec cette version, on demande de situer un pays choisi au hasard en cliquant sur le pays.
-Si on clique sur un pays, il est affiché en rouge.

Colorier Carte Monde Interrogation

Carte du Monde densité population

Carte Monde Densité population

Sub coloriageDensité()
  For Each c In [pays]
    If Not IsError(c.Offset(, 9)) Then
      popul = CDbl(c.Offset(, 9))
      p = Application.Match(popul, [légende], 1)
      couleur = Range("légende").Cells(p, 1).Interior.Color
      ActiveSheet.Shapes(c).Fill.ForeColor.RGB = couleur
    End If
   Next c
End Sub

Fonction d'écriture dans un shape

Fonction affichage libellé sur un shape

=EcritShape(B3;N3)

Function ecritShape(nomShape, Libellé)
  Application.Volatile
  With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
    .Characters.Text = Libellé
    .Characters.Font.Size = 8
   .Parent.VerticalAnchor = msoAnchorMiddle
   .Parent.HorizontalAnchor = msoAnchorCenter
  End With
  ecritShape = ""
End Function

Autre exemple

On colorie 2 flèches en fonction des valeurs en E2 et E3

=colorieimage("Axe_site1";couleur(DECALER($A$2;EQUIV(Taux_site1;légende;1)-1;)))

Colorier Flèche

Affichage d'un texte sur une photo

Cette fonction crée un Shape superposé à la photo et écrit un texte dans ce shape

AfficheTexte(groupe As Range, NomShape, Libelle)

=afficheTexte($B$3:$B$8;B3;B3)

Affichage texte photo
Affichage texte forme libre

Taille d'une image en fonction de la valeur d'une cellule

TailleImage

Function TailleImage(s, largeur, hauteur)
Application.Volatile
Set f = Sheets(Application.Caller.Parent.Name)
f.Shapes(s).Width = largeur
f.Shapes(s).Height = hauteur
End Function
End Function

Affichage d'un commentaire au survol d'une image

1- avec la boite à outils contrôles, créer un contrôle image
2- dans la propriété Picture, choisir l'image externe
3- créer une zone de texte et la nommer cmt

SurvolImage

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
    ActiveSheet.Shapes("cmt").Visible = False
  Else
    ActiveSheet.Shapes("cmt").Visible = True
  End If
End Sub

Colorier un shape au survol

Survol Shape
Survol Région

 

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
    ActiveSheet.Shapes("Bretagne").Fill.ForeColor.RGB = RGB(255, 255, 255)
  Else
    ActiveSheet.Shapes("Bretagne").Fill.ForeColor.RGB = RGB(0, 255, 0)
  End If
End Sub

Private Sub Image2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image2.Width - 10 Or Y < 10 Or Y > Image2.Height - 10 Then
    ActiveSheet.Shapes("Basse-normandie").Fill.ForeColor.RGB = RGB(255, 255, 255)
  Else
    ActiveSheet.Shapes("Basse-normandie").Fill.ForeColor.RGB = RGB(0, 255, 0)
  End If
End Sub

Private Sub Image3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image3.Width - 10 Or Y < 10 Or Y > Image3.Height - 10 Then
    ActiveSheet.Shapes("pays-de-loire").Fill.ForeColor.RGB = RGB(255, 255, 255)
  Else
    ActiveSheet.Shapes("pays-de-loire").Fill.ForeColor.RGB = RGB(0, 255, 0)
  End If
End Sub

Private Sub Image1_Click()
  razShapes
  Sheets("bretagne").Select
End Sub

Private Sub Image2_Click()
  razShapes
  Sheets("Basse-normandie").Select
End Sub

Private Sub Image3_Click()
  razShapes
  Sheets("pays-de-loire").Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  razShapes
End Sub

Sub razShapes()
   For Each s In ActiveSheet.Shapes
     s.Fill.ForeColor.RGB = RGB(255, 255, 255)
   sNext s
End Sub

Fonction constructeur de Drapeau Français et Italien

Permet de dessiner dans une cellule ou un champ des drapeaux Français ou Italien.
Si du texte est déjà présent dans la cellule ou le champ, il apparaît par transparence.

=DrapeauFR(champDrapeau; transparence)
=DrapeauIT(champDrapeau; transparence)

Sur l'exemple:

En C2: =drapeauFR(A2;50%)
En C9: =drapeauIT(A9;50%)

Constructeur Drapeau

Position flèche sur date du jour

Position flèche date du jour

 




 


Exemples

Images Synthèse
Shapes Synthèse
Photos Visibles2
Photos Visibles3
Photos Visibles4
Shape Affiche Cache
Message Attente
Elections
Barre progression
Export image Gif
Survol Image
Image Conditionnelle
Zones Textes Indicées
Filigrane
Survol texte
AffichePhoto
FonctionAfficheShape
FonctionPositionShape
Appareilphoto
FonctionAfficheImage
AlbumPhoto2
AlbumPhoto4
Trombinoscope
jb-Organigramme