Insérer des photos

Bonsoir,

Comment insérer des mini photo à coté de mes noms de régions et lorsque je clique dessus elle s'agrandissent

Merci

Bonjour,

Une piste. Attacher la sub "AgrandirRetrecir()" à un bouton après avoir adapté le chemin, le nom et les tailles de l'image :

Dim Img As Shape

Sub AgrandirRetrecir()

    If Img Is Nothing Then

        Ajouter
        Exit Sub

    End If

    If Img.Width = 50 Then Img.Width = 200 Else Img.Width = 50
    If Img.Height = 50 Then Img.Height = 200 Else Img.Height = 50

End Sub

Sub Ajouter()

    Dim Fichier As String

    Fichier = "C:\Dossier1\Dossier2\Image.JPG"

    If Dir(Fichier) <> "" Then

        Set Img = ActiveSheet.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, ActiveCell.Left, ActiveCell.Top, 50, 50)

    End If

End Sub

Bonjour,

Merci je vais essayer de comprendre ce que tu as voulu dire

Personnellement je suis au stade débutant je sais insérer une photo dans une cellule mais c tout

Peux tu stp m expliquer le chemin exact

Merci d 'avance

Le procédure commence d'abord par contrôler si l'image se trouve bien sur la feuille avec :

If Img Is Nothing Then

si Img est nothing (n'existe pas) la procédure de création et positionnement "Ajouter()" est appelée, par défaut c'est la cellule active qui sert de référence donc, l'angle gauche et haut de l'image sera positionné sur l'angle haut et gauche de la cellule. L'image a par défaut une hauteur et largeur de 50.

Une fois l'image sur la feuille, les deux lignes de code ci-dessous :

If Img.Width = 50 Then Img.Width = 200 Else Img.Width = 50
If Img.Height = 50 Then Img.Height = 200 Else Img.Height = 50

agrandissent l'image ou la rapetisse selon la taille du moment donc, si elle fait 50, alors elle est mise à 200 et si elle fait 200 alors elle estt mise à 50.

Dans la procédure "Ajouter()" il te faut écrire le chemin et nom de ton image en lieu et place du chemin bidon que j'ai écris pour l'exemple :

Fichier = "C:\Dossier1\Dossier2\Image.JPG"

Pour faire, tu ouvres l'explorateur, tu sélectionnes ton image puis dans la barre d'adresse tu copies cette dernière pour la coller entre les guillemets, tu entres un anti-slash à la fin du chemin et tu inscris le nom de l'image avec son extension.

Bonjour,

Voici un autre exemple utilisant ScaleWidth et ScaleHeight

tu doit mettre les photo dans le même répertoire que le fichier xlsm ou adapter le répertoire.

Option Explicit

Sub CréerPicture()
Dim Sh As Worksheet, i As Long, pt As Shape
Dim l As Double, t As Double, w As Double, h As Double
Set Sh = Sheets("Feuil1")  'à adapter

For i = 2 To Sh.Cells(Rows.Count, "B").End(xlUp).Row
    With Sh.Cells(i, "C")
      l = .Left
      t = .Top
      w = .Width
      h = .Height - 12
    End With

    Set pt = ActiveSheet.Shapes.AddPicture(ThisWorkbook.Path & "\" & Sh.Cells(i, "B"), msoTrue, msoTrue, l, t, w, h)  'à adapter
       With pt
         .OnAction = "Picture_Cliquer"
         .Locked = False
         .LockAspectRatio = msoFalse
         .Placement = xlMove
       End With
Next i
End Sub

Sub Picture_Cliquer()
'Agrandir ou rétrécir l'image en cliquant
Dim shp As Shape
Dim big As Single, small As Single
Dim shpDouH As Double, shpDouOriH As Double
    big = 15
    small = 1
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp
        shpDouH = .Height
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        shpDouOriH = .Height

        If Round(shpDouH / shpDouOriH, 2) = big Then
            .ScaleHeight small, msoTrue, msoScaleFromTopLeft
            .ScaleWidth small, msoTrue, msoScaleFromTopLeft
            .ZOrder msoSendToBack
        Else
            .ScaleHeight big, msoTrue, msoScaleFromTopLeft
            .ScaleWidth big, msoTrue, msoScaleFromTopLeft
            .ZOrder msoBringToFront
        End If
    End With
End Sub

Sub EffacePicture()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
  If Left(shp.Name, 7) = "Picture" Then shp.Delete
Next
End Sub