Exportieren Bild als Kommentar gesetzt

Question

füllt

Ich habe einige Codes verwendet, die ein Benutzer zu speichern, ein Bild in den Kommentaren einer Zelle unter Verwendung erlaubt:

Application.ActiveCell.AddComment.Shape.Fill.UserPicture (fName)

Ich möchte jetzt etwas schreiben, das durch die Kommentare eines Arbeitsblattes iteriert und alle oben verwendeten Bilder in separate Bilddateien exportiert. Ich bin mir nicht sicher, wie ich das richtige Objekt dafür erreichen kann.

Dank Martin

Answer 1

ich von einigen Quellen einige Code zusammengeschustert. Wie funktioniert das?

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 

Und die "Export" 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