Question

我使用了一些代码，允许用户使用以下内容将图片存储在单元格的注释中：

Application.ActiveCell.AddComment.Shape.Fill.UserPicture（fName）

我现在想写一些迭代工作表注释的内容，并将上面使用的所有图片导出到单独的图片文件中。我不确定如何达到正确的目标来做到这一点。

由于马丁

Answer 1

我从一些来源拼凑了一些代码。这是如何工作的？

Sub extractCommentImage()
'Borrowed from: https://excelribbon.tips.net/T011165_Moving_Comment_Background_Pictures_to_Cells.html
Dim cmt As Comment
Dim cel As Range
Dim bvisible As Boolean

For Each cmt In ActiveSheet.Comments
    With cmt
        bvisible = .Visible
        .Visible = True
        Set cel = .Parent.Offset(0, 1)
        .Shape.CopyPicture appearance:=xlScreen, Format:=xlPicture
        cel.PasteSpecial
        selection.ShapeRange.LockAspectRatio = msoFalse
        .Visible = bvisible
        .Shape.Fill.OneColorGradient msoGradientFromCenter, 1, 1
    End With 'cmt
Next cmt
ExportMyPicture
End Sub

和“导出”子：

Sub ExportMyPicture()
'borrowed from: https://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba
Dim MyChart As String, MyPicture As String, pic As Object
Dim PicWidth As Long, PicHeight As Long, num As Long
Dim shtName as String

num = 1

Application.ScreenUpdating = False
shtName = ActiveSheet.Name
For Each pic In ActiveSheet.Pictures

    MyPicture = pic.Name
    With pic
        PicHeight = .ShapeRange.Height
        PicWidth = .ShapeRange.Width
    End With

    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:=shtName
    selection.Border.LineStyle = 0
    MyChart = Split(ActiveChart.Name, " ")(1) & " 1"

    With ActiveSheet
        With .Shapes(MyChart)
            .Width = PicWidth
            .Height = PicHeight
        End With

        .Shapes(MyPicture).Copy

        With ActiveChart
            .ChartArea.Select
            .Paste
        End With

        .ChartObjects(1).Chart.Export Filename:="C:\Users\[CHANGE THIS]\Desktop\MyPic " & num & ".jpg", FilterName:="jpg"
        num = num + 1
        .Shapes(MyChart).Cut
    End With
Next pic
Application.ScreenUpdating = True
Exit Sub

End Sub

将图片集导出为注释填充

1 个答案: