Как скопировать картинку из другого листа и вставить внутри комментария к ячейке

Question

Итак, я нашел net, чтобы найти ответы на этот вопрос, но не нашел ни одного, поэтому я хочу, чтобы мой код делал, это открывал лист из папки, получал фотографию с этого листа и, наконец, вставлял комментарий в ячейку в моя текущая рабочая тетрадь вот мой код

Dim folder As String

Private Sub Workbook_Open()

    folder = ThisWorkbook.path

End Sub

Sub populatePDA()

    'Application.ScreenUpdating = False

    Dim wb As Workbook
    Dim ws As Variant
    Dim path As String
    Dim fileName As String
    Dim p As Picture
    Dim img As Variant
    Dim cb As Comment

    Set ws = ThisWorkbook.Sheets("PDA")
    path = folder & "\PDA\"
    fileCount = 0
    fileName = Dir(path & "*.xlsm")

    Do While fileName <> ""

        Set wb = Workbooks.Open(path & fileName) 'Open Workbook
        ws.Range("A3:F3").Insert (xlShiftDown)
        ws.Range("A3") = wb.Sheets(1).Range("B16").Value 'Item Name
        ws.Range("B3") = wb.Sheets(1).Range("B17").Value 'S/N
        ws.Range("C3") = wb.Sheets(1).Range("G7").Value 'Description
        ws.Range("D3") = wb.Sheets(1).Range("H12").Value 'Calibration
        ws.Range("E3") = wb.Sheets(1).Range("H13").Value 'Expiration

        For Each p In wb.Sheets(1).Pictures

            p.CopyPicture
            Set img = ws.Paste
            Set cb = ws.Range("F3").AddComment
            cb.Text Text:=""
            cb.Shape.Fill.UserPicture (img)

        Next p

        wb.Close
        fileName = Dir

    Loop

    'Application.ScreenUpdating = True
End Sub

Answer 1

Вы ничего не говорите, и я что-то закончил ...

Я немного изменил ваш код, добавив новую вставку в рабочий лист для нового открытого файла, и обработал их как ( Я поняла) тебе нужно. Пожалуйста, проверьте следующий код:

Sub populatePDA()
 Dim fileName As String, path As String
 Dim ws As Worksheet, wb As Workbook, p As Shape, fileCount As Long
 Dim cb As Comment, i As Long, arrCol As Variant, k As Long
  arrCol = Split("A,B,C,D,E", ",")
  Set ws = ThisWorkbook.Sheets("PDA")
  path = ThisWorkbook.path & "\PDA\"
  fileCount = 0
  fileName = Dir(path & "*.xlsm")

 k = 2
 Application.ScreenUpdating = False
 Do While fileName <> ""
    Set wb = Workbooks.Open(path & fileName) 'Open Workbook
    k = k + 1
        ws.Range("A" & k & ":E" & k).Insert (xlShiftDown)
        ws.Range("A" & k) = wb.Sheets(1).Range("B16").Value 'Item Name
        ws.Range("B" & k) = wb.Sheets(1).Range("B17").Value 'S/N
        ws.Range("C" & k) = wb.Sheets(1).Range("G7").Value 'Description
        ws.Range("D" & k) = wb.Sheets(1).Range("H12").Value 'Calibration
        ws.Range("E" & k) = wb.Sheets(1).Range("H13").Value 'Expiration
    i = 2
    For Each p In wb.Sheets(1).Shapes
       If p.Type = msoPicture Then
          i = i + 1
          ws.Activate
          If Not ws.Range(arrCol(i - 3) & k).Comment Is Nothing Then _
                                  ws.Range(arrCol(i - 3) & k).Comment.Delete
          Set cb = ws.Range(arrCol(i - 3) & k).AddComment
           cb.text text:=""
           With cb.Shape
              .width = p.width: .height = p.height
           End With
          cb.Shape.Fill.UserPicture (SelImPathCh(p, wb))
       End If
    Next p
    ws.Activate
    wb.Close False

    fileName = Dir
 Loop
 ws.UsedRange.EntireColumn.AutoFit
 Application.ScreenUpdating = False
End Sub

Функция, которая может сделать вставку изображения, следующая (она вызывается основным кодом выше):

Private Function SelImPathCh(img As Shape, Optional wb As Workbook) As String
  Dim ch As ChartObject, sh As Worksheet, sFile As String
  If Not wb Is Nothing Then Set sh = wb.Sheets(1)
  sFile = ThisWorkbook.path & "\Pict1.jpg"
  Set ch = sh.ChartObjects.Add(left:=1, _
       top:=1, width:=img.width, _
                         height:=img.height)
   If Not wb Is Nothing Then wb.Activate: sh.Activate
   img.Copy: ch.Activate: ActiveChart.Paste
   ch.Chart.Export sFile
   ch.Delete
   SelImPathCh = sFile
End Function

wb переменная Optional только для моего тестирования. Я использовал лист существующей рабочей книги и пропустил его при вызове функции ...

Answer 2

UserPicture работает с путем к файлу. Попробуйте описанный ниже метод, он должен работать.

Set cb = Worksheets(2).Range("F3").AddComment
cb.Text Text:=""
cb.Shape.Fill.UserPicture ("FILE_PATH")

И если вы хотите скопировать изображение только из рабочего листа, вы можете экспортировать изображения в папку tmp, используя следующий код, а затем указать тот же путь в UserPicture.

Sub SaveImages()
    Dim shpName As Variant
    Dim shp As Shape
    Dim ppt As Object, ps As Variant, slide As Variant

    Set ppt = CreateObject("PowerPoint.application")
    Set ps = ppt.presentations.Add

    Set slide = ps.slides.Add(1, 1)

    For Each shp In ActiveSheet.Shapes
        shpName = "D:\\tmp.jpg"
        shp.Copy
        With slide
            .Shapes.Paste
            .Shapes(.Shapes.Count).Export shpName, 2
            .Shapes(.Shapes.Count).Delete
        End With
    Next shp
    With ps
        .Saved = True
        .Close
    End With
    ppt.Quit
    Set ppt = Nothing

End Sub