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