Option Explicit
''******************************************************************************************************************************
''[COLOR=#ff8c00][B]Written by ndu96081631 - GiaiPhapExcel.com[/B][/COLOR]
''******************************************************************************************************************************
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) 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 Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) 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 Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
''******************************************************************************************************************************
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
''******************************************************************************************************************************
Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
Dim hPtr As Long, hCopy As Long, PicType As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PicType_BITMAP = 1
Const PicType_ENHMETAFILE = 4
Target.CopyPicture , IIf(bType, xlBitmap, xlPicture)
PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(PicType) <> 0 Then
If OpenClipboard(0) > 0 Then
hPtr = GetClipboardData(PicType)
If PicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
CloseClipboard
If hPtr <> 0 Then
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
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
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(PicType = CF_BITMAP, PicType_BITMAP, PicType_ENHMETAFILE)
.hPic = hCopy
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set PictureFromObject = IPic
End If
End If
End If
End Function
, chắc phải ít thời gian nữa mới lĩnh hội được. 
