Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" _
Alias "CreateDCA" (ByVal lpDriverName As String, _
lpDeviceName As Any, _
lpOutput As Any, _
lpInitData As Any _
) As Long
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObj As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" _
() As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const PICTYPE_BITMAP = 1
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const PointsPerInch = 72
Private Const SRCCOPY As Long = &HCC0020
Sub TEST()
'copy the comment picture to the shape.
Call CommentToShape(Range("a1").Comment, ActiveSheet.Shapes("Oval 1"))
End Sub
Private Sub CommentToShape(ByVal Comment As Comment, ByVal Shape As Shape)
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
Dim hBmp As Long
Dim sTempBMPFile As String
'Define the temp bmp file location.
sTempBMPFile = ThisWorkbook.Path & "\Temp.BMP"
'retrieve the BMP from the memory dc.
hBmp = BitmapFromDC(Comment)
'Retrieve the handle to the BMP Image from the clpb.
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hBmp ' Handle to image.
.hPal = 0 ' Handle to palette (if bitmap).
End With
'Create the Picture Object
Call OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic)
'Save the pic to disk.
stdole.SavePicture IPic, sTempBMPFile
'Set the shape picture.
Shape.Fill.UserPicture sTempBMPFile
'Delete the temp bmp file.
Kill sTempBMPFile
End Sub
Private Function BitmapFromDC(ByVal Comment As Comment) As Long
Dim tCommentRect As RECT
Dim tBM As BITMAP
Dim oSelection As Range
Dim hMemoryDC As Long
Dim hBmpCopy As Long
Dim lhBmpCopyOld As Long
Dim hScreenDC As Long
Dim hAppDC As Long
Dim lCol As Long
Dim lRow As Long
Dim lZoom As Long
Dim lCommentDisplaySetting As Long
'Store the worksheet initial state.
With Application
hAppDC = GetDC(.hwnd)
lCommentDisplaySetting = .DisplayCommentIndicator
lZoom = .ActiveWindow.Zoom
lCol = .ActiveWindow.ScrollColumn
lRow = .ActiveWindow.ScrollRow
.DisplayCommentIndicator = xlCommentAndIndicator
Set oSelection = Selection
.Goto Comment.Parent, True
End With
'Get the comment boundaries.
tCommentRect = GetRangeRect(Comment.Shape.OLEFormat.Object)
'Get the screen dc.
hScreenDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
'Create a compatible memory dc.
hMemoryDC = CreateCompatibleDC(hScreenDC)
'Copy the app dc onto the memory dc.
With tCommentRect
hBmpCopy = CreateCompatibleBitmap(hScreenDC, _
.right - .left, .bottom - .top)
lhBmpCopyOld = SelectObject(hMemoryDC, hBmpCopy)
BitBlt hMemoryDC, 0, 0, .right - .left _
, .bottom - .top, hAppDC, .left, .top + 2, SRCCOPY
End With
'Restore the worksheet initial state.
With Application
.DisplayCommentIndicator = lCommentDisplaySetting
.ActiveWindow.Zoom = lZoom
.ActiveWindow.ScrollColumn = lCol
.ActiveWindow.ScrollRow = lRow
.Goto oSelection
End With
'CleanUp.
SelectObject hMemoryDC, lhBmpCopyOld
DeleteDC hScreenDC
DeleteDC hMemoryDC
'Return function.
BitmapFromDC = hBmpCopy
End Function
Private Function GetRangeRect(ByVal rng As Object) As RECT
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
Dim OWnd As Window
Dim lWBHwnd As Long
On Error Resume Next
Set OWnd = rng.Parent.Parent.Windows(1)
With rng
GetRangeRect.left = _
PTtoPX(.left * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetRangeRect.top = _
PTtoPX(.top * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetRangeRect.right = _
PTtoPX(.Width * OWnd.Zoom / 100, 0) _
+ GetRangeRect.left
GetRangeRect.bottom = _
PTtoPX(.Height * OWnd.Zoom / 100, 1) _
+ GetRangeRect.top
End With
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
End Function
