Insertion d'image via macro (bouton) sans lien

Version imprimable

Bonjour a tous,

Apres avoir fait plusieurs essais, j'ai réussi a créer un bouton pour insérer une image via un bouton dans une zone ciblée (plusieurs cellules fusionnées), en passant par Pictures.Insert mais lorsque que je veux l'ouvrir sur le poste d'un collègue, les images ne sont plus présentes a cause du lien que cette fonction crée.

J'ai vu qu'il fallait maintenant passer par la fonction AddPictures, mais je ne sais pas si cela fonctionne avec un bouton.. De ce que j'en vois, non car l'image n'apparait dans le fichier.

Le but de ce classeur est qu'il soit commun a tous nos technicien, je ne veux pas passer par un chemin d'accès aux photos car ces chemins seront clairement tous différents a chaque technicien.

Je vous mets ci dessous le code avec le pictures.insert, je ne sais pas si cela est adaptable..
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 Sub insere_image() Dim ficimg As String, Ad As String Ad = Selection.Address ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier If ficimg = "Faux" Then Exit Sub ActiveSheet.Pictures.Insert(ficimg).Select ' insertion With Selection.ShapeRange .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez 'Pas besoin, c'est fait automatiquement sur la sélection '''' .Top = Range(Ad).Top ' haut de la cellule ''''' .Left = Range(Ad).Left ' gauche de la cellule .Height = Range(Ad).Height ' hauteur des cellules fusionnées .Width = Range(Ad).Width ' largeur des cellules fusionnées End With With Selection .Placement = xlMoveAndSize .PrintObject = True End With End Sub
Merci pour votre aide.
Cordialement,

29/09/2020, 07h07
Invité

Citation:

Envoyé par Lionel-FW

Bonjour,

Quel est le problème avec ce code ? Les images sont toujours présentes une fois importées.
29/09/2020, 09h29
Lionel-FW

1 pièce(s) jointe(s)

Bonjour,

Ce code fonctionne bien. La problématique est la suivante:
- Je mets a disposition plusieurs documents vierges pour des rapports d'essais chez nos clients
- Nos techniciens les remplissent et y ajoute leurs photos
- Ils nous renvoient les documents complétés mes les photos ne suivent pas.
Pièce jointe 580317

Nous devons renvoyer les rapports d'essais au client afin qu'il voit l'efficacité de nos machine, et de savoir s'ils en achètent une ou non.

Je souhaiterai avoir les photos sauvegardées dans le document, mais pouvoir l'insérer via un bouton.

Cordialement,
29/09/2020, 13h57
Invité

Citation:

Envoyé par Lionel-FW

Chez moi, les photos restent associées au fichier, je n'ai pas de liaison.
29/09/2020, 13h59
Lionel-FW

Bonjour Eric,

Même si vous déplacer le fichier ou renommer la photo importée ?

Cordialement,

Citation:

Envoyé par Lionel-FW

Effectivement le lien disparaît.

Regardez si ce code règle votre problème :

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
 
Sub TesterLInsertImage2()
 
Dim FicImg As Variant
Dim Ad As String
 
        Ad = Selection.Address
        FicImg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")
        If FicImg = "Faux" Then Exit Sub
 
        Insert_Image2 Range(Ad), FicImg
 
End Sub
 
 
Sub Insert_Image2(ByVal CelluleImage As Range, ByVal CheminImage As String)
 
Dim ShImage As Worksheet
 
Dim ImageLargeur As Single, RatioImage As Single
Dim MonImage As Shape
Dim NbShapes As Integer
 
    Set ShImage = CelluleImage.Parent
 
    With ShImage
 
        ImageLargeur = CelluleImage.Width
        RatioImage = ImageRatio(CheminImage)
 
        NbShapes = .Shapes.Count + 1
 
         ' Insertion de l'image
         '---------------------
         Set MonImage = .Shapes.AddShape(msoShapeRectangle, CelluleImage.Left, CelluleImage.Top, ImageLargeur, ImageLargeur / RatioImage)
         With MonImage
              .Name = "ImageFeuille" & NbShapes
              With .Fill
                   .Visible = msoTrue
                   .UserPicture CheminImage
              End With
              With .Line
                   .Visible = msoTrue
                   .Weight = 1
              End With
         End With
         Set MonImage = Nothing
 
    End With
 
      Set ShImage = Nothing
 
 End Sub
 
 
Function ImageRatio(ByVal CheminEtNomDeLImage As String) As Single
 
' A partir du tuto "Utiliser la librairie Windows Image Acquisition en VBA" de SilkyRoad et Bbil
 
Dim Img As Object
 
    Set Img = CreateObject("WIA.ImageFile")
    With Img
         .LoadFile CheminEtNomDeLImage
         ImageRatio = .Width / .Height
    End With
    Set Img = Nothing
 
End Function

29/09/2020, 15h13
Lionel-FW

L'image reste bien dans le fichier :)

Maintenant, c'est la taille de l'image qui ne correspond plus. La largeur est bonne par rapport aux colonnes fusionnées, par contre elle est plus longue. Serait-il possible que la photo fasse la taille de la cellule fusionnée ?

Cordialement,
29/09/2020, 15h17
Invité

Citation:

Envoyé par Lionel-FW

C'est normal car elle respecte le ratio Largeur/Hauteur. Vous avez toujours la possibilité de définir la hauteur comme dans votre précédent code.
29/09/2020, 15h54
Lionel-FW

C'est tout bon ! Affaire réglée.

Merci de votre aide, je passe la discussion en résolue.

Cordialement,
Lionel