Tuesday, December 16, 2014

Excel VBA add picture in comment box & rotate it

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