'******************************************************************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__|| // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'******************************************************************************************************************************************************
'capturer une plage en wmf et créer une image en memoire (Ipicture)pour
's'en servir dans un control image dans un userform
'patricktoulon sur developpez.com
'date/22/03/2010
'remasteurisation du code date: 12/09/2023
' api creation object image
'Option Explicit
'Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
'Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
'Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
'Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'
'Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
'Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
'Type PICTDESC: cbSize As Long: picType As Long: himage As LongPtr: hPal As LongPtr: End Type
'Function copyxlPicture(obj, Optional Ex_transparency As Boolean = False) As IPicture
' Dim hCopy As LongPtr, PictStructure As PICTDESC, DispatchInfo As GUID, IPic As IPicture, T#, p, Shap
' obj.CopyPicture
' Set p = obj.Parent
' If Ex_transparency = True Then
' p.Paste: Set Shap = p.Shapes(p.Shapes.Count)
' Shap.Fill.Visible = msoTrue: Shap.Fill.ForeColor.RGB = vbWhite: Shap.CopyPicture: Shap.Delete
' End If
' OpenClipboard 0
' T = Timer
' Do While hCopy = 0
' hCopy = CopyEnhMetaFileA(GetClipboardData(14), vbNullString): If Timer - T > 1 Then Exit Do
' Loop
' CloseClipboard
' If hCopy = 0 Then Set copyxlPicture = IPic: Exit Function ' si pas de handleimage WMF dans clip on arrete tout
' With DispatchInfo
' .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 PictStructure: .cbSize = Len(PictStructure): .picType = 4: .himage = hCopy: .hPal = 0: End With
' OleCreatePictureIndirect PictStructure, DispatchInfo, True, IPic
' Set copyxlPicture = IPic
'End Function
Option Explicit
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongPtr
Declare PtrSafe Function copyimage Lib "user32" Alias "CopyImage" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Type PICTDESC: cbSize As Long: picType As Long: himage As LongPtr: hPal As LongPtr: End Type
Function copyimagex(obj)
Dim IPic As IPicture
Dim hCopy As LongPtr
Dim tIID As GUID
Dim PictStructure As PICTDESC
Dim x As Double
Dim Ret As LongPtr
Call OpenClipboard(0): EmptyClipboard: CloseClipboard
obj.Copy 'Picture Format:=xlBitmap
OpenClipboard 0&
x = Timer
Do While (hCopy = 0)
hCopy = copyimage(GetClipboardData(&H2), 0, 0, 0, &H8)
If Timer - x > 1 Then Exit Do
Loop
CloseClipboard
If hCopy = 0 Then Set copyimagex = IPic: Exit Function
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Set copyimagex = IPic: Exit Function
With PictStructure: .cbSize = Len(PictStructure): .picType = 1: .himage = hCopy: End With
Ret = OleCreatePictureIndirect(PictStructure, tIID, 1, IPic)
If Ret Then Set copyimagex = IPic: Exit Function
Set copyimagex = IPic
Call OpenClipboard(0): EmptyClipboard: CloseClipboard
Set copyimagex = IPic
End Function
