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
Fonction qui positionne une image sur la cellule qui contient son nom
Function positionImage(cel As Range)
Application.Volatile
Set f = Sheets(Application.Caller.Parent.Name)
nomimage = cel.Value
Adr = cel.Address
f.Shapes(nomimage).Top = Range(Adr).Top - f.Shapes(nomimage).Height
/ 2
f.Shapes(nomimage).Left = Range(Adr).Left - f.Shapes(nomimage).Width
/ 2
positionImage = ""
End Function
Import avec GetOpenFilename
GetOpenFileName
GetOpenFileName 2
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
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
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 xlScreen, xlBitmap
With img.Parent.ChartObjects.Add(0, 0, img.Width, img.Height).Chart
While .Shapes.Count = 0
DoEvents
.Paste
Wend
.Export "monimage.gif", "gif"
.Parent.Delete
End With
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
Me.Image1.Picture = LoadPicture("monimage.gif")
img.Delete
End Sub
Choix d'une photo dans un contrôle image
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
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
Set s = ActiveSheet.Shapes(Application.Caller).TopLeftCell
Cells(s.Row, s.Column).Select
Visibilité
Shapes("Monshape").Visible = True
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
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
Création de shapes avec 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 d'une feuille sauf les boutons
Sub SupShapeSaufBoutons()
For Each s In ActiveSheet.Shapes
If s.Type <> 8 And s.Type <>
12 Then s.Delete
Next s
End Sub
Efface les shapes d'un champ sauf les boutons
Sub EffaceMentShapeChampSaufBoutons()
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$A$1:$D$20"))
Is Nothing Then
If s.Type <> 8 And s.Type
<> 12 Then s.Delete
End If
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
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
Créer Bulle
Image sélectionnée
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
Par programme, on affecte des liens hypertextes avec bulles à des formes.
Sub CréeBulles()
For Each s In ActiveSheet.Shapes
bulle = Application.VLookup(s.Name, [légendes],
2, False)
If Not IsError(bulle) Then
ActiveSheet.Hyperlinks.Add Anchor:=s,
Address:="", SubAddress:=""
s.Hyperlink.ScreenTip = bulle &
Chr(10) & "...."
End If
Next s
End Sub
Affichage de bulles au survol de parties d'une photo.
On ajoute des formes nommées (cercles e.g.) et par programme on affecte des liens hypertextes avec bulles à ces formes.
-Mettre la photo en arrière-plan
-Créer des formes et les nommer
Crée les liens hypertextes qui afficheront les bulles au survol
Sub CréeBulles()
For Each s In ActiveSheet.Shapes
bulle = Application.VLookup(s.Name, [légendes],
2, False)
If Not IsError(bulle) Then
ActiveSheet.Hyperlinks.Add Anchor:=s,
Address:="", SubAddress:=""
s.Hyperlink.ScreenTip = bulle &
Chr(10) & "...."
End If
Next s
End Sub
Si on clique sur le nom dans le tableur , affiche un cercle sur la photo:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Application.Index([légendes], , 1),
Target) Is Nothing And Target.Count = 1 Then
raz
nom = Target.Value
If nom <> "" Then
ActiveSheet.Shapes(nom).Line.ForeColor.RGB
= RGB(255, 0, 0)
ActiveSheet.Shapes(nom).Line.Visible
= True
End If
Else
raz
End If
End Sub
Sub raz()
For Each c In Application.Index([légendes], , 1)
If c <> "" Then
ActiveSheet.Shapes(c.Value).Line.ForeColor.RGB
= RGB(0, 255, 0)
ActiveSheet.Shapes(c.Value).Line.Visible
= False ' ou True
End If
Next
End Sub
Autre version
La propriété ControlTipText des labels invisibles crées permet d'afficher un commentaire au survol.
On modifie les propriétés des labels au survol.
Bulles
photos 2
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
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer,
ByVal X As Single, ByVal Y As Single)
Me.Commentaire.Visible = False
End Sub
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)
bulle = Application.VLookup(GrLabels.Name, [légendes],
2, False)
If Not IsError(bulle) Then
UserForm1.Commentaire.Caption = bulle
UserForm1.Commentaire.Left = GrLabels.Left
UserForm1.Commentaire.Top = GrLabels.Top - 20
UserForm1.Commentaire.Visible = True
End If
End Sub
En cliquant sur le nom de la personne dans le tableur, le commentaire est affiché sur la photo.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Application.Index([légendes], , 1),
Target) Is Nothing And Target.Count = 1 Then
nom = Target.Value
If nom <> "" Then
bulle = Target.Offset(, 1)
UserForm1.Commentaire.Caption = bulle
UserForm1.Commentaire.Left = UserForm1.Controls(nom).Left
UserForm1.Commentaire.Top = UserForm1.Controls(nom).Top
- 20
UserForm1.Commentaire.Visible = True
End If
End If
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.
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 AjoutPhotoTexte()
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
Sub SupPhotoTexte()
Set f = Sheets("bd")
nomgroupe = "DrocG"
ActiveSheet.Shapes.Range("DrocG").Ungroup
ActiveSheet.Shapes("DrocT").Delete
End Sub
Affiche du texte sur des photos
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
Liste des Groupes
Dim f
Sub ListeGroupes()
Set f = Sheets("feuil1")
i = 1
For Each c In f.Shapes
If c.Type = 6 Then
Sheets(2).Cells(i, 1) = c.Name
ListeItemsGroupe i, c.Name
i = i + 1
End If
Next c
End Sub
Sub ListeItemsGroupe(ligne, nomgroupe)
n = f.Shapes(nomgroupe).GroupItems.Count
Sheets(2).Cells(ligne, 2) = n
For j = 1 To n
Sheets(2).Cells(ligne, j + 2) = f.Shapes(nomgroupe).GroupItems(j).Name
Next j
End Sub
Groupage des formes d'un champ
Sub EssaiGroupage()
GroupeImages Range("B6:C15"), "Groupe1"
GroupeImages Range("E6:F15"), "Groupe2"
End Sub
Sub GroupeImages(champ As Range, NomGroupe)
Dim a()
n = 0
For Each s In ActiveSheet.Shapes
If Not Intersect(Range(s.TopLeftCell.Address),
champ) Is Nothing Then
n = n + 1: ReDim Preserve a(1 To n):
a(n) = s.Name
End If
Next
ActiveSheet.Shapes.Range(a).Group.Name = NomGroupe
End Sub
Sub Degroupage()
ActiveSheet.Shapes("groupe1").Ungroup
ActiveSheet.Shapes("groupe2").Ungroup
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
-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
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).
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
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
-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
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
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
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.
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,...
-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")
Si le classeur est fermé
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
Autre exemple
Affiche une image en fonction de la valeur en B8
Choix d'une image interne avec VBA
Les noms des images correspondent aux noms des personnes.
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
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.
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%.
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,...
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
Choix successifs d'images
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)
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.
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)
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
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
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
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é.
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
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
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\.
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\
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
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
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
'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.
Insertion d'une image dans des cellules fusionnées
Occupe la surface des cellules fusionnées.
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.
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
Sub ExportImage()
répertoire = ThisWorkbook.Path
Set f = ActiveSheet
nomshape = "Pédalier"
Set img = f.Shapes(nomshape)
img.CopyPicture xlScreen, xlBitmap
With img.Parent.ChartObjects.Add(0, 0, img.Width, img.Height).Chart
While .Shapes.Count = 0
DoEvents
.Paste
Wend
.Export nomshape & ".gif",
"gif"
.Parent.Delete
End With
End Sub
Exporte un champ sous forme de fichier Gif
Sub ExportZoneTableau()
Set f = ActiveSheet
fichier = ThisWorkbook.Path & "\exportimage.gif"
f.Range("A1").CurrentRegion.Select
Set champExport = Selection
champExport.CopyPicture xlScreen, xlBitmap
With champExport.Parent.ChartObjects.Add(0, 0, champExport.Width,
champExport.Height).Chart
While .Shapes.Count = 0
DoEvents
.Paste
Wend
.Export fichier, "GIF"
.Parent.Delete
End With
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)
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)
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
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()
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
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
Loupe
Double-clic pour faire apparaître/disparaître la loupe
-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
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
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
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
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.
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.
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
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
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
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
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
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.
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
Autre version avec Shapes (ne fonctionne pas sur Excel 2003)
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
Autre version avec regroupements de noms au 3e niveau
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
Carte de france
Positionne un curseur en fonction de la région choisie en col A.
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
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
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.
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.
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.
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)
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.
-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
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
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
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
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 xlScreen, xlBitmap
With s.Parent.ChartObjects.Add(0, 0, s.Width, s.Height).Chart
While .Shapes.Count = 0
DoEvents
.Paste
Wend
.Export "monimage.jpg", "Jpg"
.Parent.Delete
End With
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
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 > 3 Then p = 1
Set s = f.Shapes("photo" & p)
s.CopyPicture xlScreen, xlBitmap
With s.Parent.ChartObjects.Add(0, 0, s.Width, s.Height).Chart
While .Shapes.Count = 0
DoEvents
.Paste
Wend
.Export "monimage.jpg", "Jpg"
.Parent.Delete
End With
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)
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.
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é.
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:
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
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)
=jaugeThermo(taux;champ)
=Thermo(taux;champ;largeur%)
Fonction Jauge(taux, champJauge As Range, hauteur)
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%)
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.
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))
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%))
Le dégradé du % de chaque produit dépend du pourcentage maximum (20% sur l'exemple)
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.
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
Constructeur d'Arrière-Plan
Construction de flè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
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.
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
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
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
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
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()
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
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
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
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
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.
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
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
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
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
Fonction CouleurImage()
Donne la couleur d'une image.
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 Image 3
Colorier Image 3 B
Colorier
Image 4
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.
=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.
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
Colorier Carte
France Nom
Colorier Carte France
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
-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;)))
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
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
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
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%)
Position flèche sur date du jour
Visualisation de photos en grand au survol de photos miniatures
ListBox images
ComboBox images
ComboBox
images
ListBox images
