AfficheImage sur cellule fusionnée

awax

XLDnaute Nouveau
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 !

Code:
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

XLDnaute Accro
Re : AfficheImage sur cellule fusionnée

Bonjour,

Essaie ceci:
Code:
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

XLDnaute Nouveau
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 !
 

awax

XLDnaute Nouveau
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 !!
 

Pièces jointes

  • Copie de FonctionImageMerge.xls
    66 KB · Affichages: 60

fhoest

XLDnaute Accro
Re : AfficheImage sur cellule fusionnée

Bonjour,
j'ai regardé vite fais ,essaie ceci:
Code:
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+
 

Discussions similaires

Réponses
8
Affichages
670

Statistiques des forums

Discussions
314 450
Messages
2 109 719
Membres
110 551
dernier inscrit
Khyolyanna