Choose to Insert Image as an Image or as a Comment - excel

Question

I have code which inserts images from the given path using specific set of numbers against which I already have an image database.
Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Dim shpPic As Shape
Application.ScreenUpdating = False
fPath = "C:\Users\DELL\Documents\FY18-19\Images\"
Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
For Each r In rng
On Error GoTo errHandler
If r.Value <> "" Then
Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value & ".jpg", linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left, Top:=Cells(r.Row, 2).Top, Width:=-1, Height:=-1)
With shpPic
.LockAspectRatio = msoTrue
If .Width > Columns(2).Width Then .Width = Columns(2).Width
Rows(r.Row).RowHeight = .Height
End With
End If
errHandler:
If Err.Number <> 0 Then
Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
On Error GoTo -1
End If
Next r
Application.ScreenUpdating = True
End Sub
I need to do the below as well:
ask the file path
ask whether to insert the image as image or as a comment against those set of numbers and run accordingly
If the code can be converted into a select mode run, i.e. on a set of numbers I can run the code for (instead of the entire 'D'-Column I've embedded currently).

Answer 1

May try this code and modify to your requirement.
Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Dim shpPic As Shape, IsCmnt As VbMsgBoxResult
'Application.ScreenUpdating = False
Set rng = ThisWorkbook.ActiveSheet.Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
On Error GoTo Xexit
Set rng = Application.InputBox("Select the range to import Images", "Import Image", rng.Address, , , , , 8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = " Select Folder to Upload Images"
.AllowMultiSelect = False
.InitialFileName = "C:\Users\user\DeskTop\"
If .Show <> -1 Then Exit Sub
fPath = .SelectedItems(1)
End With
fPath = fPath & "\"
'Avoided further asking wheather all Images are to be uploaded as Comment
'instead used bold font of the file names to do the same
'try Next statement, if want all the images as comment
'IsCmnt = MsgBox("Is the images to be uploaded as comments", vbYesNo)
For Each r In rng
If r.Value <> "" Then
If Dir(fPath & r.Value & ".jpg") <> "" Then
'If IsCmnt = vbYes Then 'try this branch if want all the images as comment
If r.Font.Bold Then ' instead of asking multiple times
r.ClearComments
r.AddComment ""
r.Comment.Shape.Fill.UserPicture fPath & r.Value & ".jpg"
Else
Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value & ".jpg", linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left, Top:=Cells(r.Row, 2).Top, Width:=-1, Height:=-1)
With shpPic
.LockAspectRatio = msoTrue
If .Width > Columns(2).Width Then .Width = Columns(2).Width
Rows(r.Row).RowHeight = .Height
End With
End If
Else
Debug.Print fPath & r.Value & ".jpg not found"
End If
End If
Next r
Xexit:
'Application.ScreenUpdating = True
End Sub
Code is tested with makeshift images. May disable ScreenUpdatingas per actual condition.