Insertion d'image clipart en fonction d'un résultat

[aspipoul]

Bonjour à tous, je suis novice dans la programmation de fichier excel, donc je vais essayer d'être clair.
Voilà mon problème, je souhaite pouvoir en fonction d'un chiffre sur une case, que sur la case d'à côté un clipart s'affiche.
J'explique:
Les cases de résultats sont les suivantes de F16àF44 et de F55à F73
Ces résultats sont nécessairement les chiffres suivants 1, 6, 11, 16.
Créer les listes est facile.
Par contre je veux qu'en fonction de ces résultats, sur la colonne B16 à B44 et F55 à F73 en fonction du chiffre il y ai.
Si le chiffre est 1 deux nuages(clipart)
Si le chiffre est 6 un nuage(clipart)
Si le chiffre est 11 un soleil (clipart)
Si le chiffre est 16 deux soleils (clipart)
Et ce je souahite c'est aussi pouvoir l'étendre à d'autres lignes.
D'avance merci

 

[PMO2]

Re : Insertion d'image clipart en fonction d'un résultat

Bonjour,

Voici une solution dont la mise en place est très compliquée.

ETAPE 1
1) Créez un nouveau classeur et dans la barre de menu (tout en haut) cliquez droit puis dans le menu contextuel qui se déroule,
cliquez gauche sur "Visual Basic" pour faire apparaître sa barre d'outils
2) Cliquez sur Sécutité…/Editeurs approuvés et cochez la case "Faire confiance au projet Visual Basic"

ETAPE 2 (feuille de stockage des cliparts)
1) Créez une feuille et renommez la du nom que vous voulez (ex : clipart)
2) Faites Alt+F11 pour afficher la fenêtre de l'environnement de développement Visual Basic (VBE)
3) Faites Ctrl+R pour afficher la fenêtre Projet - VBAProject, sélectionnez la feuille qui vient d'être créée (clipart) puis
appuyez sur F4 pour afficher la fenêtre de propriétés. Changez la propriété (Name) par CLIPART (en majuscules)
4) Revenez dans Excel et dans la feuille clipart insérez les cliparts de votre choix

ETAPE 3 (code)
1) Retournez dans le VBE, faites menu Insertion/Module et copiez le code suivant dans le module

'### Constantes à adapter selon l'usage ###
Const MA_PLAGE_RESULTATS As String = "F16:F44,F55:F73"
Const DECALAGE_A_GAUCHE As Long = -4  'soit F - 4 = colonne B
'##########################################


'/// A adapter en même temps que Clips = Array(..    ///
'/// On utilisera pour cela la Sub AfficheNomClipart ///
Enum MesClipArts
  Soleil
  NuageDouble
  SoleilRadieux
  Nuage
  PereNoel
  Eclair
  Pluie
  Neige
  Nuageux
End Enum


Sub MakeClipArt(item As Long, S As Worksheet, R As Range)
Dim Clips
Dim S2 As Worksheet
Dim SH As Shape
Dim i&
'/// A adapter en même temps que Enum MesClipArts    ///
'/// On utilisera pour cela la Sub AfficheNomClipart ///
Clips = Array("Soleil", "NuageDouble", "SoleilRadieux", "Nuage", "PereNoel", _
              "Eclair", "Pluie", "Neige", "Nuageux")
'///////////////////////////////////////////////////////
Set S2 = Sheets("clipart")
Set SH = S2.Shapes(Clips(item))
SH.Copy
S.Activate
S.Paste Destination:=R
Set SH = S.Shapes(Clips(item))
SH.OnAction = "neant"
On Error Resume Next
Do
  i& = i& + 1
  SH.Name = "pmo" & i&
  If Err = 0 Then Exit Do
  Err.Clear
Loop
On Error GoTo 0
SH.Select
With Selection
  .Placement = xlMoveAndSize
  .PrintObject = True
  With .ShapeRange
    .LockAspectRatio = msoFalse
    .Left = R.Left
    .Top = R.Top
    .Height = R.Height
    .Width = R.Width
  End With
End With
End Sub

Sub neant(Optional dummy As Byte)
'''' vide mais NECESSAIRE : Evite de déplacer le ClipArt
End Sub

Sub InsertClipart()
Dim S As Worksheet
Dim SH As Shape
Dim R As Range
Dim R2 As Range
Dim C As Range
Dim NumClipart&
Dim bool As Boolean
Set S = ActiveSheet
If S.CodeName = "CLIPART" Then Exit Sub
Application.ScreenUpdating = False
Call SupprimeClipart
Set R = S.Range(MA_PLAGE_RESULTATS)
For Each C In R
  bool = False
  Select Case C
    Case 1
      NumClipart& = MesClipArts.NuageDouble
      bool = True
    Case 6
      NumClipart& = MesClipArts.Nuage
      bool = True
    Case 11
      NumClipart& = MesClipArts.Soleil
      bool = True
    Case 16
      NumClipart& = MesClipArts.SoleilRadieux
      bool = True
    '--- par exemple
    Case 25
      NumClipart& = MesClipArts.PereNoel
      bool = True
    Case 26
      NumClipart& = MesClipArts.Pluie
      bool = True
  End Select
  If bool Then
    Set R2 = C.Offset(0, DECALAGE_A_GAUCHE)
    Call MakeClipArt(NumClipart&, S, R2)
  End If
Next C
S.[a1].Select
Application.ScreenUpdating = True
End Sub

Private Sub SupprimeClipart()
Dim S As Worksheet
Dim SH As Shape
Set S = ActiveSheet
If S.CodeName = "CLIPART" Then Exit Sub
Application.ScreenUpdating = False
For Each SH In S.Shapes
  If Right(SH.OnAction, 5) = "neant" Then SH.Cut
Next SH
End Sub

'*** Macro à lancer à la main en cliquant en son intérieur
'*** et en faisant F5. Les noms initiaux apparaissent dans
'*** la fenêtre d'Exécution. Changez les noms au fur et à
'*** mesure. Relancez cette macro afin de copier les nouveaux
'*** noms dans la fenêtre d'Exécution et les coller dans
'*** Enum MesClipArts ainsi que dans Clips = Array(...
'*** (voir en haut de la page au début du code )
Private Sub AfficheNomClipartEtRenomme()
Dim WB As Workbook
Dim S As Worksheet
Dim SH As Shape
Set WB = ThisWorkbook
WB.Activate
For Each S In WB.Sheets
  If S.CodeName = "CLIPART" Then
    Set S = S
    Exit For
  End If
Next S
S.Select
On Error Resume Next
WB.VBProject.VBE.Windows("Exécution").Visible = True
On Error GoTo 0
For Each SH In S.Shapes
  SH.Select
  Debug.Print SH.Name
  Stop
  '--- Pour changer le nom du ClipArt décocher la ligne ---
  '--- Indiquer des noms d'un seul tenant (sans espace) ---
'  SH.Name = "toto"     'adapter le nouveau nom à chaque passage
  '--------------------------------------------------------
Next
End Sub

2) Adaptez à votre usage les constantes MA_PLAGE_RESULTATS et DECALAGE_A_GAUCHE
3) Lancez la macro AfficheNomClipartEtRenomme à l'intérieur du VBE (voir explications dans le code)
et renommez vos cliparts
4) Modifiez en conséquence Enum MesClipArts et Clips = Array(…
5) Dans la Sub InsertClipart adapter le code au niveau du Select Case C

Il n'y a plus qu'à lancer la macro InsertClipart.
En espérant n'avoir rien oublié et que c'est compréhensible je vous souhaite bon courage.

Cordialement.

Le fichier, même zippé, dépasse la capacité autorisée par ce forum.
Vous pouvez le télécharger chez http://cjoint.com/?bAsJeJjSIs

PMO
Patrick Morange