Option Explicit
Private Type Size
cx As Single
cy As Single
End Type
Private Type uPicDesc
Size As Long
Type As Long
#If Win64 Then
hPic As LongLong
hPal As LongLong
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
#If Win64 Then
bmBits As LongLong
#Else
bmBits As Long
#End If
End Type
#If VBA7 Then
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (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 OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If
Private Function GetShapeRealSize(ByVal Shp As Shape) As Size
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Dim tSize As Size, tBM As BITMAP, oPic As StdPicture
Set oPic = PicFromObject(Shp)
Call GetObjectAPI(oPic.Handle, LenB(tBM), tBM)
With tSize
.cx = PXtoPT(tBM.bmWidth, False)
.cy = PXtoPT(tBM.bmHeight, True)
End With
GetShapeRealSize = tSize
End Function
Private Function PicFromObject(ByVal obj As Variant) As StdPicture
Const IMAGE_BITMAP = 0
Const PICTYPE_BITMAP = 1
Const LR_COPYRETURNORG = &H4
Const CF_BITMAP = 2
Const S_OK = 0
#If Win64 Then
Dim hImagePtr As LongLong
#Else
Dim hImagePtr As Long
#End If
Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
Dim IPic As StdPicture
On Error GoTo errHandler
obj.CopyPicture xlScreen, xlBitmap
Call OpenClipboard(0)
hImagePtr = GetClipboardData(CF_BITMAP)
hImagePtr = CopyImage(hImagePtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call EmptyClipboard
Call CloseClipboard
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hImagePtr
.hPal = 0
End With
If OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) = S_OK Then
Set PicFromObject = IPic
End If
Exit Function
errHandler:
Call EmptyClipboard
Call CloseClipboard
End Function
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
#If Win64 Then
Dim hdc As LongLong
#Else
Dim hdc As Long
#End If
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Static lDPI(1) As Long
If lDPI(0) = 0 Then
hdc = GetDC(0)
lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
ReleaseDC 0, hdc
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
Const POINTSPERINCH As Long = 72
PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function