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 |
Partager