XL 2013 VBA Insérer image dans zone sélectionnée

[Jouxte]

Bonjour à toutes et tous,

J'utilise le code ci-dessous pour coller, redimensionner et centrer horizontalement l'image du presse papier dans la cellule active de ma feuille.

Sub InsertionCellActiveImagePressePapier()

    Dim Img As Object
    
     If Application.ActiveSheet.Paste Then
 
    Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            
            .LockAspectRatio = msoTrue
            
            .Top = ActiveCell.Top + 1
            .Height = ActiveCell.Height - 1
            .Left = ActiveCell.Left + ((ActiveCell.Width - Img.Width) / 2)
            '.Width = ActiveCell.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

J'aurais souhaité :
pouvoir coller cette image, la redimensionner pour qu'elle ne dépasse pas soit en largeur soit en hauteur de la ou des cellules contiguës sélectionnées.

Par avance merci pour votre aide.

 

[Dudu2]

Bonjour,

Dans ce fichier un Module_ImportImage contenant le fonction ImportImage() pour placer une image fichier ou Objet dans une cellule ou une plage grâce à des paramètres divers décrits dans les commentaires de la fonction.

 

[Jouxte]

Bonjour Dudu2,
Merci pour cette solution. Elle ne correspond pas vraiment à ce que je souhaite faire.
J'ai fait évoluer mon code (en réutilisant des bouts de code @patricktoulon) pour que l'image soit redimensionnée à la taille de la cellule, mais je n'ai pas réussi à le faire sur plusieurs cellules.
Je vais voir si je peux m'inspirer du code de l'exemple ci-dessus.
Voici le code modifié

Sub InsertionCellActivePressePapier2()

    Dim Img As Object
    Dim ratio#, W#, H#
  
 
    If Application.ActiveSheet.Paste Then
 
    Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            
            .LockAspectRatio = msoTrue
          ratio = .Width / .Height
          W = ActiveCell.Width
          H = ActiveCell.Height
          If (W / H < ratio) Then
            .Width = W
          Else
            .Height = H - ratio
          End If

 

[Dudu2]

pour que l'image soit redimensionnée à la taille de la cellule

En conservant les proportions de l'image ou pas ?

 

[Jouxte]

En conservant les proportions de l'image ou pas ?

Oui.
Mon code n'est pas passé en entier.le voici complet.

Sub InsertionCellActivePressePapier2()

    Dim Img As Object
    Dim ratio#, W#, H#
  
 
    If Application.ActiveSheet.Paste Then
 
    Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            
            .LockAspectRatio = msoTrue
          ratio = .Width / .Height
          W = ActiveCell.Width
          H = ActiveCell.Height
          If (W / H < ratio) Then
            .Width = W
          Else
            .Height = H - ratio
          End If
            
            .Top = ActiveCell.Top + ((ActiveCell.Height - Img.Height) / 2)
            .Left = ActiveCell.Left + ((ActiveCell.Width - Img.Width) / 2)
            
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

 

[Dudu2]

Merci pour cette solution. Elle ne correspond pas vraiment à ce que je souhaite faire.

Edit: Fichier supprimé, voir ci-dessous

 

[Jouxte]

Merci pour cette solution. Elle correspond vraiment à ce que je souhaite faire.

 

[patricktoulon]

re
Bonjour
purée j'ai pourtant donné des solutions complètes
les deux méthodes que je donne dans la ressource ont fait le tour du monde

c'est a ce demander si ça en vaut vraiment la peine

mes méthode travaille sur une cellule ou un range en gardant l'aspect ratio

 

[Jouxte]

Bonjour Patricktoulon,

Je me suis inspiré de la méthode directe car je n'ai pas réussi à utiliser directement cette méthode (et encore moins la méthode indirecte) pour mon cas à savoir coller l'image du presse papier dans une ou plusieurs cellules.
Mais je suis preneur du code qui va bien. Par avance merci.

 

[Dudu2]

Bonjour @patricktoulon, @Jouxte,

Je ne vois pas ce que tu as contre la fonction que j'ai fournie qui est un code ancien de mon backlog.
Cette fonction donne des options de cadrage diverses ou d'insertion d'une image Objet ou Fichier que ta ressource n'a pas. Je pourrais d'ailleurs la mettre aussi en ressources.
Ce n'est pas parce que tu as fourni une ressource que tout le monde est obligé de l'utiliser, ce que d'ailleurs @Jouxte a essayé sans réussir.
En plus ton screenshot d'erreur basé sur un Clipboard vide ou non approprié (qui ne relève d'alleurs pas de ma fonction) n'est pas très cool non plus.

Je passe à Toulon ce matin. On pourra en discuter

 

[Dudu2]

@Jouxte,

Pour éviter l'erreur que @patricktoulon a provoquée en ne respectant pas la consigne à l'écran:

j'ai légèrement modifié la macro d'appel pour garantir que le presse-papier contient une image.

 

[patricktoulon]

re
Bonsoir
il faut me prévenir a l'avance je bosse beaucoup en ce moment je n'ai que le mardi et le dimanche de libre