'-----------------------------------
'Importer une image dans une feuille
'-----------------------------------
'Parameters:
'----------
'- ImageFullName Image path and file name
'
'- Cell Target Cell to place the image (can be merged cells)
'
'- ObjectName Imposed name of the resulting Image Object or Shape Object
'
'- msoShape If the image has to be placed in a Shape,
' Type of Shape (see https://docs.microsoft.com/en-us/office/vba/api/office.msoautoshapetype)
' Exemple: msoShapeRectangle
'
'- msoShapeBorderWeight If msoShape specified, its border weight
'
'- msoShapeBorderColor If msoShape specified, its border RGB color
'
'- InCell True to place the image into the Cell
' False to place the image outside the Cell
'
' - InCellHMarginPercentage If InCell = True, percentage of Cell Width for horizontal margin from Cell (the margin applies to left & right)
'
' - InCellVMarginPercentage If InCell = True, percentage of Cell Height for vertical margin from Cell (the margin applies to top & bottom)
'
'- Align If InCell = True, image position into the Cell
' - Keeps the original image proportions:
' "Top", "Bottom", "Left", "Right", "Centre" (défaut)
' - Modify image proportions:
' "Cover"
'
' If InCell = False, image top left corner position in relation to the Cell
' - Keeps the original image proportions:
' "TopLeft" (défaut), "TopRight", "BottomLeft", "BottomRight", "Centre"
'
' - ResizeRatio If InCell = False, resize ratio to apply to the image
'
'Return:
'------
'- Created Image Object name or Shape Object name
'-----------------------------------
Function ImportImage(ByVal ImageFullName As String, _
ByVal Cell As Range, _
Optional ByVal ObjectName As String = vbNullString, _
Optional ByVal msoShape As String = vbNullString, _
Optional ByVal msoShapeBorderWeight As Single = 1, _
Optional ByVal msoShapeBorderColor As Long = 0, _
Optional ByVal InCell As Boolean = True, _
Optional ByVal InCellHMarginPercentage As Single = 0, _
Optional ByVal InCellVMarginPercentage As Single = 0, _
Optional ByVal Align As String = vbNullString, _
Optional ByVal ResizeRatio As Single = 1) As String
Dim Pic As Picture
Dim Shp As Shape
Dim RatioWidth As Single
Dim RatioHeight As Single
Dim ZonePicTop As Single
Dim ZonePicLeft As Single
Dim ZonePicWidth As Single
Dim ZonePicHeight As Single
Dim Left As Single
Dim Top As Single
Dim S As String
'Vérification nom de l'image
If Len(Dir(ImageFullName)) = 0 Then Exit Function
'Vérification des marges InCell
With Cell.MergeArea
If InCell Then
If InCellHMarginPercentage >= 1 Or InCellVMarginPercentage >= 1 Then Exit Function
ZonePicLeft = .Left + (.Width * InCellHMarginPercentage)
ZonePicTop = .Top + (.Height * InCellVMarginPercentage)
ZonePicWidth = .Width - 2 * (.Width * InCellHMarginPercentage)
ZonePicHeight = .Height - 2 * (.Height * InCellVMarginPercentage)
End If
End With
'Insertion de l'image sur l'ActiveCell
Set Pic = ActiveSheet.Pictures.Insert(ImageFullName)
'----------
'Image size
'----------
'Image dans la cellule
If InCell Then
Select Case UCase(Align)
Case "TOP", "BOTTOM", "LEFT", "RIGHT", "CENTRE"
RatioWidth = Application.Min(ZonePicWidth / Pic.Width, ZonePicHeight / Pic.Height)
Pic.ShapeRange.LockAspectRatio = msoTrue
Case "COVER"
RatioWidth = ZonePicWidth / Pic.Width
RatioHeight = ZonePicHeight / Pic.Height
Pic.ShapeRange.LockAspectRatio = msoFalse
Case Else
RatioWidth = Application.Min(ZonePicWidth / Pic.Width, ZonePicHeight / Pic.Height)
Pic.ShapeRange.LockAspectRatio = msoTrue
End Select
'Image hors de la cellule
Else
RatioWidth = ResizeRatio
Pic.ShapeRange.LockAspectRatio = msoTrue
End If
'Set image size
Pic.Width = Pic.Width * RatioWidth
If Pic.ShapeRange.LockAspectRatio = msoFalse Then Pic.Height = Pic.Height * RatioHeight
'--------------
'Image position
'--------------
'Image dans la cellule
If InCell Then
'Alignement dans la cellule
Select Case UCase(Align)
Case "TOP"
Top = ZonePicTop
Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
Case "BOTTOM"
Top = ZonePicTop + ZonePicHeight - Pic.Height
Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
Case "LEFT"
Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
Left = ZonePicLeft
Case "RIGHT"
Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
Left = ZonePicLeft + ZonePicWidth - Pic.Width
Case "CENTRE"
Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
Case Else
Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
End Select
'Image hors de la cellule
Else
With Cell.MergeArea
'Alignement par rapport à la cellule
Select Case UCase(Align)
Case "TOPLEFT"
Left = .Left
Top = .Top
Case "TOPRIGHT"
Left = .Left + .Width
Top = .Top
Case "BOTTOMLEFT"
Left = .Left
Top = .Top + .Height
Case "BOTTOMRIGHT"
Left = .Left + .Width
Top = .Top + .Height
Case "CENTRE"
Left = .Left + .Width / 2
Top = .Top + .Height / 2
Case Else
Left = .Left
Top = .Top
End Select
End With
End If
'Nom par défaut de l'objet à créer (Image ou Shape)
S = Mid(ImageFullName, InStrRev(ImageFullName, "\") + 1)
S = Mid(S, 1, InStrRev(S, ".") - 1)
'L'image doit être placée dans un Shape
If Len(msoShape) > 0 Then
'Set Shp = Cell.Parent.Shapes.AddShape(msoShapeRectangle, Left, Top, pic.width, pic.height)
Set Shp = Cell.Parent.Shapes.AddShape(msoShape, Left, Top, Pic.Width, Pic.Height)
Shp.Line.Weight = msoShapeBorderWeight
Shp.Line.ForeColor.RGB = msoShapeBorderColor
Shp.Fill.UserPicture ImageFullName
If Len(ObjectName) Then Shp.Name = ObjectName Else Shp.Name = S
ImportImage = Shp.Name
Pic.Delete
'L'image doit rester indépendante
Else
Pic.Left = Left
Pic.Top = Top
If Len(ObjectName) Then Pic.Name = ObjectName Else Pic.Name = S
ImportImage = Pic.Name
End If
End Function