Index

Positionnement Adresse Cellule Shape Visibilite Creation Shape Suppression Types de shapes Image arrière plan Affichage cellule dans zone de texte Appareil Photo Insertion d'une image Choix d'une image interne Choix d'une image externe Import d'images Export d'un champ vers fichier Gif Transforme un graphe en image Export d'un graphe en Gif

-Choix d'une Photo -Image conditionnelle -Planning -Défilement de texte -Clignotement d'un shape -Copie un champ dans un formulaire -Visualistation d'un champ au survol d'une cellule -Chronomètre -Loupe -Générique -Compter images champ -Modifier forme commentaire -Curseur horizontal -Photo en commentaire -Fonction AfficheImage -TrombinoscopeBD

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

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

Visibilité

Shapes("Monshape").Visible = True

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"

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:=1).Font.ColorIndex = 3
.Fill.ForeColor.SchemeColor = 13
.TextFrame.Characters.Font.Size = 11
.TextFrame.Characters(Start:=1, Length:=12).Font.Size = 7
End With

Ecriture

ActiveSheet.Shapes("monshape").TextFrame.Characters.Text = "ceci est un essai"

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

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"

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

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

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

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

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.Adjustments(1) = 0.1
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

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)
-Attribuer une image de fond à la photo avec
Clic-droit/Format de l'image/Couleurs et traits/Couleurs/Motifs et textures/Images

Autre exemple

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.

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

-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

Insertion d'une image

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

Sub ImportImage()
  repertoire = ThisWorkbook.Path & "\"
  [B2].Select
  Set monimage = ActiveSheet.Pictures.Insert(repertoire & [A2] & ".jpg")
  monimage.Height = ActiveCell.Height
  monimage.Width = ActiveCell.Width
End Sub

Affiche la photo 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

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("b2")) Is Nothing Then
    ChDir ActiveWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Range("B7").Select
    monimage = ActiveSheet.Pictures.Insert(Range("B2") & ".jpg").Select
    Selection.Name = "monimage"
    Me.Shapes("Labulle").Visible = True
    Me.Shapes("Labulle").OLEFormat.Object.Text = "Je m'appelle " & [b2]
    [b2].Select
  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 en fonction du nom

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

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("b2")) Is Nothing Then
     repertoire = ThisWorkbook.Path & "\"
     On Error Resume Next
     ActiveSheet.Shapes("monimage").Delete
     p = Application.Match([B2], [NOMS], 0)
     If Not IsError(p) Then
       image = Range("images")(p)
       Range("B7").Select
       monimage = ActiveSheet.Pictures.Insert(repertoire & image).Select
       Selection.Name = "monimage"
     End If
    [B2].Select
  End If
End Sub

Affiche la photo associée au nom

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Range("A2:A5")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    ChDir ActiveWorkbook.Path
    On Error Resume Next
    Shapes("monimage").Delete
    nomimage = Target & ".jpg"
    Target.Offset(0, 1).Select
    monimage = ActiveSheet.Pictures.Insert(nomimage).Select
    Selection.Name = "monimage"
    Shapes("monimage").Left = ActiveCell.Left + 5
    ActiveCell.Offset(0, -1).Select
    Application.EnableEvents = True
  End If
End Sub

Choix d'une image avec données/Validation

Images internes au classeur

Choix d'une image interne

Les noms des images coorespondent 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

Plusieurs images

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

DVImagesInternes.xls

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

Autre exemple

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

ChoixImage

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

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

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

Images externes au classeur

Choix d'une seule image externe

Les noms des images correspondent aux noms des personnes.

ChoixImage

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
    rep = ThisWorkbook.Path ' adapter
    nf = rep & "\" & Target & ".jpg"
    Target.Offset(2, 0).Select
    Set image = ActiveSheet.Pictures.Insert(nf)
      If Err > 0 Then
        MsgBox "Inconnu"
     Else
       image.Name = "MonImage"
     End If
     On Error GoTo 0
     Target.Select
   End If
End Sub

Pour adapter la hauteur de ligne à la hauteur de l'image

ActiveCell.EntireRow.RowHeight = Shapes("monimage").Height

Pour adapter la hauteur de l'image à la hauteur de la ligne

Shapes("monimage").Height = ActiveCell.Height

Pour adapter la taille de l'image à la taille de la cellule

image.Height = ActiveCell.Height
image.Width = ActiveCell.Width

Pour adapter la taille de l'image à la taille d'un champ

image.Height = [A4:B6].Height
image.Width = [A4:B6].Width

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

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, 2).Address Then
           s.Delete
         End If
       End If
      Next s
      '--
      rep = ActiveWorkbook.Path
      'rep = "c:\xyz"
      nomimage = rep & "\" & Target & ".jpg"
      Target.Offset(0, 2).Select
      On Error Resume Next
      ActiveSheet.Pictures.Insert(nomimage).Select
      If Err > 0 Then MsgBox "inconnu"
      Selection.Name = Target
      On Error GoTo 0
      Target.Select
    End If
End Sub

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 du classeur Excel

Sub ImportImages()
  repertoire = ThisWorkbook.Path & "\"
  nf = Dir(repertoire & "*.jpg") ' premier fichier
  Range("b2").Select
  Do While nf <> ""
    Set monimage = ActiveSheet.Pictures.Insert(nf)
    monimage.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 = monimage.Height + 0
    nf = Dir ' suivant
    ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Sub suppression()
   For Each i In ActiveSheet.Shapes
     ActiveSheet.Shapes(i.Name).Delete
   Next i
End Sub

Les noms des images à importer sont dans la colonne A

On suppose que les images .jpg sont dans le répertoire du classeur Excel

Sub ImportImages2()
  repertoire = ThisWorkbook.Path
  Range("b2").Select
  Do While ActiveCell.Offset(0, -1) <> ""
     nf = repertoire & "\" & ActiveCell.Offset(0, -1) & ".jpg"
     Set monimage = ActiveSheet.Pictures.Insert(nf)
     ActiveCell.EntireRow.RowHeight = monimage.Height + 0
     ActiveCell.Offset(1, 0).Select
  Loop
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

Function AfficheImage(NomImage, Optional rep As String)
  Application.Volatile
  If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
  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
     Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr.Width,         adr.Height)
     s.Name = NomImage & "_" & adr.Address
  End If
End Function

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

AfficheImage3

Function AfficheImage(NomImage, rep)
  Application.Volatile
  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")
       Set myFolder = myShell.Namespace(rep)
       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
       Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H)
       s.Name = NomImage & "_" & adr.Address
       AfficheImage = "ok"
    End If
  End If
End Function

Trombinoscope

En A2: =DECALER(BD!$A$2;(ENT(LIGNES($1:2)/2)*4+COLONNES($A:A)-5);0)

En A1: =AfficheImage(A2&".jpg";"c:\mesdoc\")

Trombinoscope

Function AfficheImage(NomImage, Optional rep)
   Application.Volatile
   If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
   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
         Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, adr.Width,            adr.Height)
         s.Name = NomImage & "_" & adr.Address
         AfficheImage = "ok"
       End If
    End If
End Function

Exporte une zone de tableau sous forme de fichier Gif

Sub ExportZoneTableau()
  Range("A1").CurrentRegion.Select
  Set champExport = Selection
  champExport.CopyPicture
  ActiveSheet.Paste
  ActiveSheet.ChartObjects.Add(0, 0, champExport.Width, champExport.Height).Chart.Paste
  ActiveSheet.ChartObjects(1).Chart.Export "imageExport.gif", "gif"
  ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
  ActiveSheet.Shapes(ActiveSheet.Shapes.Count).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

Choix d'une photo

Placer une photo dans la feuille.

Créer un nom de champ avec Insertion/Nom/Définir

Adr: =INDEX(Photo;EQUIV(AffichePhoto4!$B$1;produit;0))

Dans la barre de formule de l'image en B2:=Adr

- AffichePhoto -

Noms de champ
Adr =INDEX(Photo;EQUIV(AffichePhoto4!$B$1;produit;0))
Photo =DECALER(AffichePhoto4!$J$2;;;NBVAL(AffichePhoto4!$I:$I)-1)
produit =DECALER(AffichePhoto4!$I$2;;;NBVAL(AffichePhoto4!$I:$I)-1)

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

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

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

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

Créer une zone de texte et la nommer MonShape
-DéfileShape.xls-

Sub defile()
   t = "Faites défiler un texte dans un shape pendant un temps donné.Gestion des commentaires dans les cellules:    écriture, modification, forme,images de fond, planning,... "
   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

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

Planning

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

Private Sub UserForm_Initialize()
  ChDir ActiveWorkbook.Path
  With Sheets("shapeForm")
    .[A1:E6].CopyPicture
    .Paste Destination:=.Range("A1") 'crée un shape
    Set s = .Shapes(.Shapes.Count)
    s.CopyPicture
    .ChartObjects.Add(0, 0, s.Width, s.Height * 1.15).Chart.Paste
    .ChartObjects(1).Chart.Export Filename:="monimage.jpg", FilterName:="jpg"
    .Shapes(.Shapes.Count).Delete
    .Shapes(.Shapes.Count).Delete
   End With
   Me.Image1.Picture = LoadPicture("monimage.jpg")
End Sub

Chronomètre

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.

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

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 -

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

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

Triangle vert

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column >= 1 And Target.Column <= 3 Then
    On Error Resume Next
    Shapes("curseur").Visible = True
    If Err <> 0 Then
       ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1000, 1).Name = "curseur"
    End If
    ActiveSheet.Shapes("curseur").Line.ForeColor.RGB = RGB(0, 0, 255)
    Shapes("curseur").Top = ActiveCell.Top + ActiveCell.Height
    Shapes("curseur").Height = 1
    Shapes("curseur").Width = [A1:C1].Width
  Else
    On Error Resume Next
    Shapes("curseur").Visible = False
  End If
End Sub