Correction code insertion photo

Bonjour,

J'ai besoin d'un peu d'aide concernant un code qui insert automatiquement une photo.

J'ai trouvé deux codes mais ils ont chacun leur défaut malheureusement, mais ils fonctionnent tous deux.

Mon premier code qui insert une photo dans une cellule fusionnée.

Le soucis c'est que la photo même réduite déborde je n'arrive pas à appliquer un code pour qu'elle s'ajuste à la cellule.

L'avantage c'est que si la photo n'existe pas il ne me met pas d'erreur et que les photos se trouvent dans le même répertoire donc pas besoin de nommer le chemin.

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("F14")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F14") & ".jpg")
    img.Name = "monimage"
    img.Left = [M7].Left
    img.Top = [M7].Top

Mon second code, plus simple est lié à un cadre image de la boite à outils contrôles.

La photo ne déborde plus mais elle n'apparait pas en entier..

De plus si la photo n'existe pas, un message d'erreur apparait.

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

Si quelqu'un pouvait me dire comment modifier le code de facon à ce que l'image s'adapte aux dimension soit de la cellule ou du cadre et comment remplacer le message d'erreur par un message Box par exemple.

Merci beaucoup

Jeremy

Bonjour,

Ayant modifié le titre et ma demande, je me permet de faire remonter ce post.

Jeremy

Bonjour

Dans le premier code rajoutes (attention fait de mémoire - et à mon age ...)

    img.Height = [M7].Height
    img.Width = [M7].Width

Et dans le 2ème

If Dir(répertoirePhoto & "\" & Target & ".jpg") = "" Then 
  MsgBox "Image inexistante"
  Exit Sub
End If
    Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")
   End If
End Sub 

bonjour

ci joint un fichier, télechargé ici dans mon bon FORUM d'excel-pratique

peu être qu'il peu vous aider

a vous relire

59nouveau-dossier.rar (41.39 Ko)

Merci pour vos interventions.

Le fichier je m'en suis jsutement servi pour mes deux codes, ceui que j'ai consulté est d'ailleurs bien plus étoffé.

Encore faut il savoir utiliser et adapter les codes, ce qui n'est pas vraiment mon cas.

Banzaï,

Ton premier code ne fonctionne pas, M7 étant une cellule fusionnée.

Du coup l'image apparait de la taille d'origine de la cellule M7, minuscule.

Ma deuxième formule que j'avais réussi à appliquer à mon classeur aujourd'hui ne veut plus fonctionner, donc je n'ai pas encore pu tester ton code, mais dont je ne doute pas fonctionne à merveille.

 Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")

Etant surligné en jaune??

Reste toujours ce problème de taille d'image..

Merci,

J'ai trouvé mon erreur dans mon second code.

Je vais poster l'intégralité du code, car en ajoutant la partie du code de Banzaï, une erreur apparait:

Erreur de compilation

End If sans bloc If

J'ai essayé de bidouiller pour que ca fonctionne mais... non.

Le code qui gère également une liste déroulante et des lignes.

Je n'ai pas pu faire autrement que de les mettre ensemble puisque créer un deuxième Private Sub Worksheet_Change(ByVal Target As Range) me donnait un code d'erreur "nom ambigue" si je me souviens bien.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$F$20" Then
    Select Case UCase(Range("F20"))
      Case "GRAVILLON ROULE"
       Rows("72:74").Hidden = True
       Rows("117:118").Hidden = True
       Rows("106:107").Hidden = False
       Rows("120:123").Hidden = False
      Case "MULCH"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = False
       Rows("117:118").Hidden = True
       Rows("120:123").Hidden = False
       Case "GAZON NATUREL"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = True
       Rows("118:118").Hidden = False
       Rows("120:123").Hidden = True
       Case "SABLE"
       Rows("72:74").Hidden = False
       Rows("106:107").Hidden = False
       Rows("117:118").Hidden = True
       Rows("120:123").Hidden = False
       Case "SOL STABILISE"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = True
       Rows("118:118").Hidden = False
       Rows("121:123").Hidden = True
       Case "SOL SYNTHETIQUE"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = False
       Rows("118:118").Hidden = False
       Rows("120:12").Hidden = True
       Rows("123:123").Hidden = False

    End Select
    End If

  If Target.Address = "$F$17" Then
     répertoirePhoto = "C:\Documents and Settings\211211\Bureau\Photo" 'adapter
     Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")
   End If
If Dir(répertoirePhoto & "\" & Target & ".jpg") = "" Then
  MsgBox "Image inexistante"
  Exit Sub
End If
    Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")
   End If
End Sub

Bonjour

JeremyW a écrit :

Ton premier code ne fonctionne pas, M7 étant une cellule fusionnée.

Quand on dit (assez souvent) de joindre un fichier, j'aurais vu le problème et je t'aurais proposé une autre solution

exemple

 
    img.Height = [M7].Offset(1, 0).Top - [M7].Top
    img.Width = [M7].Offset(0, 1).Left - [M7].Left 

Édit

Changes la fin de la macro

  ' .
  ' .
  ' .
  If Target.Address = "$F$17" Then
    répertoirePhoto = "C:\Documents and Settings\211211\Bureau\Photo" 'adapter
    If Dir(répertoirePhoto & "\" & Target & ".jpg") = "" Then
      MsgBox "Image inexistante"
    Else
      Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Target & ".jpg")
    End If
  End If
End Sub

Merci Banzaï,

C'est vrai que d'habitude je met un fichier et je dois l'avouer ça aurait été plus simple.

Je pensais pouvoir m'en passer.

Ton code fonctionne très bien et place l'image à l'endroit escompté.

Cependant j'aimerais mettre une deuxiéme photos en M24.

Mais la deuxième efface la première alors qu'elles ont chacune un emplacement désigné...

J'ai essayé en modifiant End If Exit Sub mais je n'y parviens pas.

Si tu pouvais m'aider à résoudre ce dernier point

Merci,

S'il le faut je crée un exemple.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$F$20" Then
    Select Case UCase(Range("F20"))
      Case "GRAVILLON ROULE"
       Rows("72:74").Hidden = True
       Rows("117:118").Hidden = True
       Rows("106:107").Hidden = False
       Rows("120:123").Hidden = False
      Case "MULCH"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = False
       Rows("117:118").Hidden = True
       Rows("120:123").Hidden = False
       Case "GAZON NATUREL"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = True
       Rows("118:118").Hidden = False
       Rows("120:123").Hidden = True
       Case "SABLE"
       Rows("72:74").Hidden = False
       Rows("106:107").Hidden = False
       Rows("117:118").Hidden = True
       Rows("120:123").Hidden = False
       Case "SOL STABILISE"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = True
       Rows("118:118").Hidden = False
       Rows("121:123").Hidden = True
       Case "SOL SYNTHETIQUE"
       Rows("72:74").Hidden = True
       Rows("106:107").Hidden = True
       Rows("117:117").Hidden = False
       Rows("118:118").Hidden = False
       Rows("120:12").Hidden = True
       Rows("123:123").Hidden = False

    End Select
    End If

  If Not Intersect(Target, Range("F17")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F17") & ".jpg")
    img.Name = "monimage"
    img.Left = [M7].Left
    img.Top = [M7].Top
 img.Height = [M7].Offset(1, 0).Top - [M7].Top
    img.Width = [M7].Offset(0, 1).Left - [M7].Left

Exit Sub
 End If
 If Not Intersect(Target, Range("F18")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F18") & ".jpg")
    img.Name = "monimage"
    img.Left = [M24].Left
    img.Top = [M24].Top
 img.Height = [M24].Offset(1, 0).Top - [M24].Top
    img.Width = [M24].Offset(0, 1).Left - [M24].Left
End If
End Sub

Bonjour

Effaces manuellement tes 2 images

Remplaces ton code par celui-ci

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$F$20" Then
    Select Case UCase(Range("F20"))
      Case "GRAVILLON ROULE"
        Rows("72:74").Hidden = True
        Rows("117:118").Hidden = True
        Rows("106:107").Hidden = False
        Rows("120:123").Hidden = False
      Case "MULCH"
        Rows("72:74").Hidden = True
        Rows("106:107").Hidden = False
        Rows("117:118").Hidden = True
        Rows("120:123").Hidden = False
      Case "GAZON NATUREL"
        Rows("72:74").Hidden = True
        Rows("106:107").Hidden = True
        Rows("117:117").Hidden = True
        Rows("118:118").Hidden = False
        Rows("120:123").Hidden = True
      Case "SABLE"
        Rows("72:74").Hidden = False
        Rows("106:107").Hidden = False
        Rows("117:118").Hidden = True
        Rows("120:123").Hidden = False
      Case "SOL STABILISE"
        Rows("72:74").Hidden = True
        Rows("106:107").Hidden = True
        Rows("117:117").Hidden = True
        Rows("118:118").Hidden = False
        Rows("121:123").Hidden = True
      Case "SOL SYNTHETIQUE"
        Rows("72:74").Hidden = True
        Rows("106:107").Hidden = True
        Rows("117:117").Hidden = False
        Rows("118:118").Hidden = False
        Rows("120:12").Hidden = True
        Rows("123:123").Hidden = False
    End Select
  ElseIf Not Intersect(Target, Range("F17")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F17") & ".jpg")
    img.Name = "monimage"
    img.Left = [M7].Left
    img.Top = [M7].Top
    img.Height = [M7].Offset(1, 0).Top - [M7].Top
    img.Width = [M7].Offset(0, 1).Left - [M7].Left
  ElseIf Not Intersect(Target, Range("F18")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage2").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F18") & ".jpg")
    img.Name = "monimage2"
    img.Left = [M24].Left
    img.Top = [M24].Top
    img.Height = [M24].Offset(1, 0).Top - [M24].Top
    img.Width = [M24].Offset(0, 1).Left - [M24].Left
  End If
End Sub

Il ne faut pas que les 2 images portent le même nom

justement, une image est nommée 710 et l'autre 1710.

Ca devrait être bon nan?

Bonjour

Ce sont les noms des fichiers dans ton répertoire, mais une fois chargés dans la feuille tu les renommes

Dans la macro que tu as posté tu le fais avec le même nom

  If Not Intersect(Target, Range("F17")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F17") & ".jpg")
    img.Name = "monimage"
    img.Left = [M7].Left
    img.Top = [M7].Top
 img.Height = [M7].Offset(1, 0).Top - [M7].Top
    img.Width = [M7].Offset(0, 1).Left - [M7].Left

Exit Sub
 End If
 If Not Intersect(Target, Range("F18")) Is Nothing Then
    répertoire = ThisWorkbook.Path
    On Error Resume Next
    ActiveSheet.Shapes("monimage").Delete
    Set img = ActiveSheet.Pictures.Insert(répertoire & "\" & Range("F18") & ".jpg")
    img.Name = "monimage"
    img.Left = [M24].Left
    img.Top = [M24].Top
 img.Height = [M24].Offset(1, 0).Top - [M24].Top
    img.Width = [M24].Offset(0, 1).Left - [M24].Left
End If
End Sub

Regardes la macro que je t'ai proposée

Excuses moi Banzaï je n'ai même pas vu que tu avais changé le code.

Je te remercie pour ton implication.

Ca fonctionne parfaitement.

Rechercher des sujets similaires à "correction code insertion photo"