Option Explicit
Sub InsertPicToComment()
Dim strFileThumbnail As String
strFileThumbnail = CreateThumbnail("D:\Temp\Pic\IMG_0105.JPG", Sheet1, 100, 100)
If Not Sheet1.Range("C5").Comment Is Nothing Then Sheet1.Range("C5").Comment.Delete
With Sheet1.Range("C5").AddComment
.Visible = True
.Text Text:=""
.Shape.Fill.UserPicture strFileThumbnail
.Shape.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
.Visible = False
End With
Kill strFileThumbnail
End Sub
Function CreateThumbnail(ByVal strFilePic As String, ByVal wksSheet As Worksheet, _
ByVal lngThumb_Width As Long, ByVal lngThumb_Height As Long) As String
' input jpg and temp file path
Dim strFileThumbnail As String
Dim strFolderPic As String
With CreateObject("Scripting.FileSystemObject")
strFolderPic = .GetParentFolderName(strFilePic)
If Right(strFolderPic, 1) <> "\" Then strFolderPic = strFolderPic & "\"
strFileThumbnail = strFolderPic & .GetBaseName(strFilePic) & "_Thumb." & .GetExtensionName(strFilePic)
End With
' load picture to shape and RESIZE
Dim oShapePic As Shape
Set oShapePic = wksSheet.Shapes.AddPicture(Filename:=strFilePic, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, _
Left:=20, Top:=20, Width:=lngThumb_Width, Height:=lngThumb_Height)
' create a chart
Dim oChart As Chart
Set oChart = wksSheet.Shapes.AddChart(xlColumnClustered, Width:=lngThumb_Width, Height:=lngThumb_Height).Chart
' copy shape picture to chart and export to file thumbnail
oShapePic.Copy
oChart.Paste
oChart.Export Filename:=strFileThumbnail, FilterName:="jpg"
' Delette shape picture to chart After export to file thumbnail
oShapePic.Delete
oChart.Parent.Delete
CreateThumbnail = strFileThumbnail
End Function
