I’m asking for your help. My research ended up in 2 different macros that combined will give a good utility for my work.
- This VBA code will insert image as comment.
- This VBA code will fetch Hyperlinks(Local folder path only, not web based URL) and paste them in destination cell.
I really tried to combine them to do one job, but I guess I don’t have enough knowledge on this.
I tried to make a single script that gets the links from source range
Set Rng = Application.InputBox("Please select the url cells:")
Then prompt for destination cells (Application.InputBox(“Please select a cell to put the image as comment:).
Now This is the tricky part for me, I need the images to be inserted as comment as the 1st code does to the destination range user selects.
Can anyone guide to achieve this excellent tweak
Sub InsertPictureAsComment() Dim PicturePath As String Dim CommentBox As Comment 'Pick A File to Add via Dialog (PNG or JPG) With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .title = "Select Comment Image" .ButtonName = "Insert Image" .Filters.clear .Filters.Add "Images", "*.png; *.jpg" .Show 'Store Selected File Path On Error GoTo UserCancelled PicturePath = .SelectedItems(1) On Error GoTo 0 End With 'Clear Any Existing Comment Application.ActiveCell.ClearComments 'Create a New Cell Comment Set CommentBox = Application.ActiveCell.AddComment 'Remove Any Default Comment Text CommentBox.Text Text:="" 'Insert The Image and Resize CommentBox.Shape.Fill.UserPicture (PicturePath) CommentBox.Shape.ScaleHeight 6, msoFalse, msoScaleFormTopLeft CommentBox.Shape.ScaleWidth 4.8, msoFalse, msoScaleFromTopLeft 'Ensure Comment is Hidden (Swith to TRUE if you want visible) CommentBox.Visible = False Exit Sub 'ERROR HANDLERS UserCancelled: MsgBox "Done" End Sub
Sub URLToCellPictureInsert() Dim Pshp As Shape Dim xRg As Range Dim xCol As Long On Error Resume Next Set Rng = Application.InputBox("Please select the url cells:", "", Selection.Address, , , , , 8) If Rng Is Nothing Then Exit Sub Set xRg = Application.InputBox("Please select a cell to put the image as comment:", "", , , , , , 8) If xRg Is Nothing Then Exit Sub Application.ScreenUpdating = False For i = 1 To Rng.Count filenam = Rng(i) ActiveSheet.Pictures.Insert(filenam).Select Set Pshp = Selection.ShapeRange.Item(1) If Pshp Is Nothing Then GoTo lab xCol = cell.Column + 1 Set xRg = xRg.Offset(i - 1, 0) With Pshp .LockAspectRatio = msoFalse .Width = 80 .Height = 80 .Top = xRg.Top + (xRg.Height - .Height) / 2 .Left = xRg.Left + (xRg.Width - .Width) / 2 End With lab: Set Pshp = Nothing Range("A2").Select Next Application.ScreenUpdating = True End Sub