Вставить изображение в качестве изображения / в качестве комментария (должен быть выбор) путем поиска по заданному пути, следуя определенному номеру элемента

Question

У меня есть приведенный ниже код vba, который может вставлять изображения по заданному пути, используя определенный набор чисел, для которых у меня уже есть база данных изображений.Но в основном нужен код, который также может выполнять следующие действия:

1. спрашивать путь к файлу
2. спрашивать, вставлять ли изображение как изображение или как комментарий к этому набору чисел ивыполнить соответственно
3. Если приведенный ниже код можно преобразовать в запуск режима выбора, т. е. на наборе чисел, для которого я могу выполнить код (вместо всей колонки 'D', которую я сейчас внедрил).

Может кто-нибудь помочь мне здесь ....

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

Answer 1

Можете попробовать этот код и изменить его по вашему требованию.

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

Код проверен с временными изображениями. Может отключить ScreenUpdating в соответствии с фактическим состоянием.