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
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.