AfficheImage sur cellule fusionnée

[awax]

Bonjour,

J'ai cherché mais ne trouve pas...
J'ai utilisé le code ci-dessous pour afficher des images selon la valeur d'une cellule, cela fonctionne mais une seule fois, dès que je tape une autre valeur dans la cellule référence, l'image apparaît bien mais en tout petit et pas du tout à l'échelle de la cellule fusionnée.

Quelqu'un aurait-il une solution ??

Merci beaucoup de votre aide et joyeuses fêtes !

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

 

[fhoest]

Re : AfficheImage sur cellule fusionnée

Bonjour,

Essaie ceci:

Sub taille_auto()
Dim x As String
Dim y As String
Dim h As Double
Dim w As Double

Dim diff1 As Double
Dim diff2 As Double

For Each p In ActiveSheet.Shapes
ActiveSheet.Shapes(p.Name).Select
If Selection.ShapeRange.Rotation = 90 Then GoTo image_pivoter
  x = p.TopLeftCell.Address
  y = p.BottomRightCell.Address
  h = Range(x).Height
  w = Range(x).Width
  ActiveSheet.Shapes(p.Name).LockAspectRatio = msoFalse
  ActiveSheet.Shapes(p.Name).Left = Range(x).Left + 1
  ActiveSheet.Shapes(p.Name).Top = Range(y).Top + 1
  ActiveSheet.Shapes(p.Name).Height = h - 2
  ActiveSheet.Shapes(p.Name).Width = w - 2
  GoTo image_suivante:
image_pivoter:
  x = p.TopLeftCell.Address
  y = p.BottomRightCell.Address
  w = Range(x).Height
  h = Range(x).Width
  ActiveSheet.Shapes(p.Name).LockAspectRatio = msoFalse
  ActiveSheet.Shapes(p.Name).Height = h - 2
  ActiveSheet.Shapes(p.Name).Width = w - 2
  diff1 = ActiveSheet.Shapes(p.Name).Height
  diff2 = ActiveSheet.Shapes(p.Name).Width
  ActiveSheet.Shapes(p.Name).Top = Range(y).Top - ((diff1 - diff2) / 2)
  ActiveSheet.Shapes(p.Name).Left = Range(x).Left + ((diff1 - diff2) / 2)
image_suivante:
Next p
End Sub

ce n'est peut être pas adapter à ton exemple mais cela gère l'affichage de shapes
A toi de voir.
A+

 

[awax]

Re : AfficheImage sur cellule fusionnée

Bonjour,

Merci mais cela ne fonctionne pas, les images ne s'adaptent pas à la taille de la cellule fusionnée dans laquelle se trouve la fonction "affiche image".

Je pense avoir compris où se situe le problème, si en cellule A1 =afficheimage(A2&".jpg"), en fait A2='feuil2'!A1
Le problème est donc que la cellule A2 où je vais chercher la valeur est elle même une fonction qui reprend la valeur d'une autre cellule dans une autre feuille.

J'ai le même problème si je saisis en directement A1=afficheimage('feuil1'!A2'&".jpg"), l'image ne prend pas la taille de la cellule fusionnée mais seulement de la 1ère.

En revanche, si je saisis directement la valeur en A2, la fonction marche parfaitement!

Comment faire pour que l'image se redimensionne correctement malgré que la valeur soit dans une autre feuille ?
J'espère que vous comprendrez...

Merci beaucoup de votre aide et bonne année !

 

[fhoest]

Re : AfficheImage sur cellule fusionnée

Bonjour bonne année également
le problème est trop vagues ,pourrais tu mettres un fichier en exemple avec la macro, une ou deux images etc... pour travailler dessus
A+

 

[awax]

Re : AfficheImage sur cellule fusionnée

Bonjour,

Voici un fichier en exemple, donc en feuille 1 l'image insérée par la fonction Afficheimage dans la cellule fusionnée B4 ne se redimensionne pas car la valeur est recherchée en A1 de l'onglet 2.

Merci de ton aide !!

 

[fhoest]

Re : AfficheImage sur cellule fusionnée

Bonjour,
j'ai regardé vite fais ,essaie ceci:

Sub taille_auto()
Dim x As String
Dim y As String
Dim h As Double
Dim w As Double

Dim diff1 As Double
Dim diff2 As Double

For Each p In ActiveSheet.Shapes
ActiveSheet.Shapes(p.Name).Select
If Selection.ShapeRange.Rotation = 90 Then GoTo image_pivoter
x = p.TopLeftCell.Address
y = p.BottomRightCell.Address
If Range(x).MergeCells = True Then
h = Range(x).MergeArea.Height
w = Range(x).MergeArea.Width
Else:
h = Range(x).Height
w = Range(x).Width
End If
  ActiveSheet.Shapes(p.Name).LockAspectRatio = msoFalse
  ActiveSheet.Shapes(p.Name).Left = Range(x).Left + 1
  ActiveSheet.Shapes(p.Name).Top = Range(y).Top + 1
  ActiveSheet.Shapes(p.Name).Height = h - 2
  ActiveSheet.Shapes(p.Name).Width = w - 2
  GoTo image_suivante:
image_pivoter:
  x = p.TopLeftCell.Address
  y = p.BottomRightCell.Address
  w = Range(x).Height
  h = Range(x).Width
  ActiveSheet.Shapes(p.Name).LockAspectRatio = msoFalse
  ActiveSheet.Shapes(p.Name).Height = h - 2
  ActiveSheet.Shapes(p.Name).Width = w - 2
  diff1 = ActiveSheet.Shapes(p.Name).Height
  diff2 = ActiveSheet.Shapes(p.Name).Width
  ActiveSheet.Shapes(p.Name).Top = Range(y).Top - ((diff1 - diff2) / 2)
  ActiveSheet.Shapes(p.Name).Left = Range(x).Left + ((diff1 - diff2) / 2)
image_suivante:
Next p
End Sub

A savoir le code fonctionne si il n'y a pas un doublon d'image et que l'image source est plus petite que la cellule dans laquelle elle est placée au départ.
A+