Insertion image a la taille de la cellule

Version imprimable

19/04/2013, 09h36
skyzix

Insertion image a la taille de la cellule

Bonjour

je souhaite coller une image dans une cellules et que cette image soit automatiquement a la taille de la cellule.
sachant que l'image se trouve dans le presse papier (copier / coller)

Merci pour votre aide :ccool:
19/04/2013, 10h11
Jean-Philippe André

Salut,

en utilisant le macro recorder on trouve des choses. Mais en cherchant dans la :faq: aussi :
http://excel.developpez.com/faq/?pag...ImageClipBoard

Pour la copie dans le presse papier, qu'as-tu utilisé jusqu'à présent ?

UNe fois le collage fait, en passant par les informations Top/Left/Width/Height de la cellule, tu devrais retomber sur tes pattes :)

Bonjour

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Macro1()
    Dim Photo As Variant
    Dim Gauche, Sommet, Largeur, Hauteur As Single
 
    Photo = Application.GetOpenFilename("Images JPEG (*.jpg), *.jpg")
    Gauche = Range("C2").Left
    Sommet = Range("C2").Top
    Largeur = Range("C2").Width
    Hauteur = Range("C2").Height
 
    If Photo <> False Then
        Feuil1.Shapes.AddPicture Photo, True, True, Gauche, Sommet, Largeur, Hauteur
    End If
End Sub

Pour le moment j'en suis là
Mais je ne pige pas bien pour récupérer l'image dans le presse papier
dans le code ci-dessous je vais chercher l'image dans un dossier

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub InsertionImage()
    Dim Emplacement As Range
    Dim Img As Object
    Dim ShapeObj As Shape
 
    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
    Next ShapeObj
 
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        'Définit l'emplacement de l'image
        Set Emplacement = Range("D3:E8")
 
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

Bonjour

Après avoir fouiné un peu partout

j'ai trouvé cela pour récupérer l'image dans le presse papier

Code:

1
2
3
4
5
If My.Computer.Clipboard.ContainsImage() Then
  Dim grabpicture As System.Drawing.Image
  grabpicture = My.Computer.Clipboard.GetImage()
  picturebox1.Image = grabpicture
End If

Pouvez-vous d'aider a fusionner les deux bout de code
merci

Bon finalement en bidouillant dans tout les sens j'ai fini par trouvé
Je ne sais si c'est top niveau code mais ca fonctionne

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub InsertionImage()
    Dim Emplacement As Range
    Dim Img As Object
    Dim ShapeObj As Shape
 
    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
    Next ShapeObj
 
    If Application.ActiveSheet.Paste Then
        'Définit l'emplacement de l'image
        Set Emplacement = Range("D3:E8")
 
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

Bonjour

Au boulot ils ont changé tous nos PC et maintenant nous avons Excel 2010
depuis que nous avons cette version mon code ne fonctionne plus

C'est a dire qu'il récupère le fichier PDF, le colle a emplacement prévu puis il affiche la Msgbox
Il ne renomme pas le fichier en "cible2" ni redimensionne l'objet.

je ne trouve pas le problème
merci de votre aide ;)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
Sub InsertionPDF2()
    Dim Emplacement As Range
    Dim PDF As Object
    Dim ShapeObj As Shape
    Chemin = "\\Dellserver\Share2\LABO\Base de travail\Fichiers temporaires\temp XG\"
    texte = "Art49566_OF" & Range("h5") & ".002"
    'Boucle pour supprimer l'ancien pdf
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible2" Then ActiveSheet.Shapes("Cible2").Delete
    Next ShapeObj
 
    If ActiveSheet.OLEObjects.Add(Filename:=Chemin & texte & ".pdf", Link _
        :=False, DisplayAsIcon:=False).Select Then
        'Définit l'emplacement du pdf
        Set Emplacement = Range("A77:H99")
 
        Set PDF = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With PDF.ShapeRange
            'Nommer le PDF insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible2"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

08/11/2017, 21h47
patricktoulon

re

bonsoir

je viens d'essayer ton code sur 2007 et il fonctionne
peu être a tu un soucis avec le serveur

Bonjour

Bon après mettre un peu archer les cheveux j'ai trouvé cette solution qui fonctionne.
la différence c'est qu'il ouvre une fenêtre pour lui indiquer le chemin du fichier PDF.
Au finale ce n'est pas plus mal cela évite d'avoir un chemin de dossier spécifique et un nom de fichier PDF avec le mème formalisme

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
 
Sub InsertionPDF2()
    Dim Emplacement As Range
    Dim PDF As Object
    Dim ShapeObj As Shape
 
    'Boucle pour supprimer l'ancien pdf
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible2" Then ActiveSheet.Shapes("Cible2").Delete
    Next ShapeObj
 
 
 
      If ActiveSheet.OLEObjects.Add(ClassType:="AcroExch.Document.DC", Link:=False, _
        DisplayAsIcon:=False).Activate Then
        'Définit l'emplacement du pdf
        Set Emplacement = Range("A77:H99")
 
        Set PDF = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With PDF.ShapeRange
            'Nommer le PDF insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible2"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

Résolu pour moi 8-)