[Insert Picture into Excel cell] inserts an image of user's choice into cell boundary #excel #vba

insertpic.bas

Option Explicit
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Const CSIDL_PERSONAL As Long = &H5
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Function Rep_Documents() As String
Dim lRet As Long, IDL As ITEMIDLIST, sPath As String
lRet = SHGetSpecialFolderLocation(100&, CSIDL_PERSONAL, IDL)
If lRet = 0 Then
sPath = String$(512, Chr$(0))
lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
Rep_Documents = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
Else
Rep_Documents = vbNullString
End If
End Function
Sub addPictureToCell()
Dim pictureFilePath As String

pictureFilePath = picturePath()

If pictureFilePath = "No File Selected" Then Exit Sub

Call insertPictureInCell(pictureFilePath)

End Sub
Sub insertPictureInCell(picturePath As String)
 
Dim s As Shape
Dim name As String
 
name = Format(Now(), "yyyyMMddHHmmss")
 
'add rectangle Container
With ActiveCell
    Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=.Left, _
            Top:=.Top, Width:=.Width, Height:=.Height)
    s.name = name
End With
 
'insert picture into Rectangle
ActiveSheet.Shapes.Range(Array(name)).Select
With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .UserPicture picturePath
    .TextureTile = msoFalse
    .RotateWithObject = msoTrue
End With
End Sub

Function picturePath() As String
'file dialogue adapted from https://www.wiseowl.co.uk/blog/s209/type-filedialog.htm
Dim fd As FileDialog
 
Set fd = Application.FileDialog(msoFileDialogOpen)
 
'the number of the Button chosen
Dim FileChosen As Integer
FileChosen = fd.Show
 
fd.Title = "Choose picture to add to cell"
fd.InitialFileName = Rep_Documents()
fd.InitialView = msoFileDialogViewList
 
'show Excel workbooks and macro workbooks
fd.Filters.Clear
fd.Filters.Add "JPEG", "*.jpg"
fd.Filters.Add "PNG", "*.png"
 
fd.FilterIndex = 1
 
fd.ButtonName = "Select"
 
If FileChosen <> -1 Then
     'didn't choose anything (clicked on CANCEL)
    picturePath = "No file Selected"
Else
     'get file, and open it (NAME property
     'includes path, which we need)
    picturePath = fd.SelectedItems(1)
End If
 
End Function