Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function CopyImage Lib "user32.dll" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const IMAGE_ENHMETAFILE As Long = 3
Sub SaveCommentPicturesToFile(CommentsInThisRange As Range)
Dim r As Range, c As Comment
Application.ScreenUpdating = False
On Error Resume Next
MkDir ThisWorkbook.Path & Application.PathSeparator & "CommentPics"
On Error GoTo 0
ChDir ThisWorkbook.Path & Application.PathSeparator & "CommentPics"
For Each r In CommentsInThisRange
Set c = r.Comment
If Not c Is Nothing Then
c.Visible = True
c.Shape.CopyPicture xlScreen, xlBitmap
c.Visible = False
SavePicture PicFromClip, "CPic_" & r.Address(0, 0) & ".bmp."
End If
Next
End Sub
Private Function PicFromClip() As IPictureDisp
Dim BitmapHandle As Long, Pic As PicBmp, IPic As IPictureDisp, IID_IDispatch As GUID
If OpenClipboard(0) <> 0 Then
BitmapHandle = CopyImage(GetClipboardData(2), 0, 0, 0, LR_COPYRETURNORG)
CloseClipboard
End If
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = BitmapHandle
.hPal = vbNull
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
Set PicFromClip = IPic
End Function