如何从另一个工作表复制图片并粘贴到单元格注释中

Question

所以我在网上寻找答案，但没有找到答案，我希望我的代码做的是从文件夹中打开工作表，从该工作表中获取照片，最后粘贴到我当前工作簿中单元格内的评论中。 这是我的代码

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