Code for doing same is given below:
Option Explicit
Sub InsertPictures()
Dim cll As Range
Dim Rng As Range
Dim strPath As String
Dim objChart1 As ChartObject
Dim pic As Object
strPath = "D:\Photo Folder"
With Sheets("Sheet1")
Set Rng = Range("A2:A416")
End With
For Each cll In Rng
If Dir$(strPath & "\" & cll.Value & ".jpg") <> "" Then
With cll
'Adding comment
.ClearComments
.AddComment ("")
.Comment.Shape.Fill.UserPicture (strPath & "\" & cll.Value & ".jpg")
.Comment.Shape.Height = 600 '160
.Comment.Shape.Width = 400 '120
.Comment.Shape.LockAspectRatio = msoTrue
.Comment.Visible = True
'Copy paste picture/duplicating picture
.Comment.Shape.Select
.Comment.Shape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.Comment.Visible = False
.Offset(0, 1).PasteSpecial
'Rotating Picture
Selection.ShapeRange.IncrementRotation 270#
Set pic = Selection.ShapeRange
'Creating chart object pasting picture in it & exporting to temp file
Set objChart1 = ActiveSheet.ChartObjects.Add(100, 100, 200, 160)
objChart1.Activate
ActiveSheet.Shapes(pic.Name).Copy
ActiveChart.Paste
ActiveChart.Export Filename:=ThisWorkbook.Path & "\" & "x01z9.jpg", FilterName:="JPEG"
'Adding back rotated pic to comment
.Select
.ClearComments
.AddComment ("")
.Comment.Visible = True
.Comment.Shape.Height = 120
.Comment.Shape.Width = 160
.Comment.Shape.Fill.UserPicture ThisWorkbook.Path & "\" & "x01z9.jpg"
'.Comment.Shape.Fill.UserPicture (strPath & "\" & cll.Value & ".jpg")
'Clearing temp objects
pic.Delete
objChart1.Select
objChart1.Delete
Kill (ThisWorkbook.Path & "\" "x01z9.jpg")
End With
End If
Next cll
End Sub
No comments:
Post a Comment