Insertion image dans un fichier

Version imprimable

bonjour tout le monde,
je cherche depuis un moment comment faire pour insérer dans un fichier excel une image à partir d'un répertoire donné
j'ai essayé d'adapter ce code que j'ai trouvé sur le net mais le seul prob c'est que je n'est pas le bon répertoire directement à l'ouverture
comment faire pour préciser le répertoire ou ce trouve les images

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("B25:J38")
 
        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

merci d'avance pour votre aide

11/09/2017, 18h00
Invité

Citation:

Envoyé par SOTUMA

Bonjour,

Un exemple de chargement de photos ici : chargement-automatique-photos
12/09/2017, 16h28
SOTUMA

Citation:

Envoyé par Eric KERGRESSE

Bonjour,

Un exemple de chargement de photos ici : chargement-automatique-photos

merci pour le lien mais ce n'est pas ce que je cherche
ce que je cherche c'est plus simple je cherche a insérer une seule image
le code que j'ai posté ouvre un répertoire image autre que le répertoire de travail comment modifier le code pour qu'il ouvre un répertoire donné
tout mon prob vient de cette instruction

Code:

Application.Dialogs(xlDialogInsertPicture).Show

elle ouvre un repertoire par defaut comment faire pour rendre mon répertoire de travail en tant que répertoire par défaut
merci pour votre aide

Citation:

Envoyé par SOTUMA

A tester : Nécessite la référence Microsoft Windows Image Acquisition Library

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
 
Option Explicit
 
' Nécessite la référence Microsoft Windows Image Acquisition Library
 
Sub RecupererLImage(ByVal FeuilleEnCours As Worksheet, ByVal CelluleImage As Range, ByVal Repertoire As String)
 
Dim LargeurImage As Single, HauteurImage As Single
Dim Img As WIA.ImageFile
 
Dim MonImage As Shape
Dim MonFichier As Variant
 
    With FeuilleEnCours
 
         ChDir Repertoire
 
         MonFichier = Application.GetOpenFilename("Fichiers Image (*.jpg;*.gif;*.png;*.tif;*.bmp),*.jpg;*.gif;*.png;*.tif;*.bmp")
         If MonFichier = False Then Exit Sub
 
          For Each MonImage In .Shapes
             Select Case MonImage.Name
                    Case "Cible"
                         .Shapes("Cible").Delete
             End Select
         Next MonImage
 
         Set Img = CreateObject("WIA.ImageFile")
         Img.LoadFile MonFichier
         If Img.Width > Img.Height Then
            LargeurImage = 319 ' A adapter
            HauteurImage = LargeurImage / Img.Width * Img.Height
         Else
            LargeurImage = 212 ' A adapter
            HauteurImage = LargeurImage / Img.Width * Img.Height
         End If
         Set Img = Nothing
 
         Set MonImage = .Shapes.AddShape(msoShapeRectangle, CelluleImage.Left, CelluleImage.Top, LargeurImage, HauteurImage)
         With MonImage
              .Name = "Cible"
              With .Fill
                   .Visible = msoTrue
                   .UserPicture MonFichier
                   .TextureTile = msoFalse
                   .ForeColor.ObjectThemeColor = msoThemeColorText1
              End With
              With .Line
                   .Visible = msoTrue
                   .Weight = 1
              End With
          End With
 
     End With
 
End Sub
 
Sub TestRecupererLesImages()
 
        With ActiveSheet
             RecupererLImage ActiveSheet, .Range("B25"), .Range("RepertoireImage")
        End With
 
End Sub