'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'Module de copie en image (JPG / EMF / WMF / PNG / BMP) de tout object sur feuille(Range / Shapes / Graphique / etc...)
's'en servir dans un control image dans un userform
'ou exporter
'patricktoulon sur developpez.com
'utilisation d'un clisd pour la structure IPictureIID pour le Bitmap
'date/22/03/2010
'remasteurisation du code date: 12/09/2023
'api creation object image
'mise ajour 18/09/2023
'ajout de la fonction copyObjToEmfFile( fichier ".EMF")
'abandon du vb6
'mise à jour 15/11/2024
'Ajout de la fonction CopyPngPicture
'ajout de l'export en WMF directe
'intervenant
'@patricktoulon
'@jurassic pork
'@Rhemm
Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As LongPtr) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
Private Declare PtrSafe Function CopyMetaFileA Lib "gdi32" (ByVal hmf As LongPtr, ByVal lpFileName As String) As LongPtr
Private Declare PtrSafe Function DeleteMetaFile Lib "GDI32.dll" (ByVal hmf As LongPtr) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As LongPtr) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (Destination As Any, ByVal Source As LongPtr, ByVal Length As LongPtr)
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
'--------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------
'LA FONCTION POUR LE FORMAT WMF renvoi un object IpictureDisp
Function copyxlPicture(obj, Optional lPath As String = "") As IPicture
'@patricktoulon
Dim hCopy As LongPtr, PictStructure As PICTDESC, DispatchInfo As GUID, ipic As IPicture, T#
obj.CopyPicture
OpenClipboard 0
T = Timer
Do While hCopy = 0
hCopy = CopyEnhMetaFileA(GetClipboardData(&HE), 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
If lPath <> "" Then SavePicture ipic, lPath: Set ipic = Nothing
OpenClipboard 0: EmptyClipboard: CloseClipboard
End Function
'--------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------
'LA FONCTION POUR LE FORMAT EMF
Function copyObjToEmfFile(obj As Object, Optional cheminX = "")
'@patricktoulon
'@jurassic pork
Dim hMeta As LongPtr, hCopy As LongPtr
If cheminX = "" Then cheminX = ThisWorkbook.Path & "\captureObject.emf"
' Copier la shape au format Metafile
obj.CopyPicture
' Récupérer l'image en Metafile dans le presse papier et le sauve vers un fichier
If OpenClipboard(0) Then
hMeta = GetClipboardData(&HE) ' CF_ENHMETAFILE = 0x14 (format EMF)soit au format Hex "&HE"
If hMeta <> 0 Then hCopy = CopyEnhMetaFileA(hMeta, cheminX) ' Copier l'EMF dans un fichier
DeleteEnhMetaFile hCopy ' Libérer la mémoire
End If
CloseClipboard ' Fermer le presse-papiers
copyObjToEmfFile = cheminX
End Function
'LA FONCTION POUR LE FORMAT WMF
Function copyObjToWmfFile2(obj As Object, Optional cheminX = "")
'@Rheeem
'@Patricktoulon
Dim hMeta As LongPtr, hCopy As LongPtr, hGlobal As LongPtr
If cheminX = "" Then cheminX = ThisWorkbook.Path & "\captureObject.Wmf"
OpenClipboard (0): EmptyClipboard: CloseClipboard 'vide le clipboard
obj.CopyPicture ' Copier la shape au format Metafile
' Récupérer l'image en Metafile dans le presse papier et le sauve vers un fichier
If OpenClipboard(0) Then
If IsClipboardFormatAvailable(&H3) = 0 Then MsgBox " pas de meta dans le clip": Exit Function
hGlobal = GetClipboardData(&H3) ' VF_METAFILE = 0x3 (format WMF)soit au format Hex "&H3"
hMeta = GlobalLock(hGlobal): GlobalUnlock hGlobal
RtlMoveMemory hMeta, hMeta + 12, Len(hMeta)
If hMeta <> 0 Then hCopy = CopyMetaFileA(hMeta, cheminX) ' Copier l'EMF dans un fichier
If hCopy <> 0 Then DeleteMetaFile hCopy
End If
CloseClipboard ' Fermer le presse-papiers
copyObjToWmfFile2 = cheminX
End Function
'--------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------
'LA FONCTION POUR LE FORMAT BMP
Function CopyBitmapPicture(obj As Object, Optional lPath As String = "")
'patricktoulon
Dim ipic As IPicture, hCopy&, tIID As GUID, PictStructure As PICTDESC, x#, ret&
Call OpenClipboard(0): EmptyClipboard: CloseClipboard
obj.CopyPicture 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 CopyBitmapPicture = ipic: Exit Function
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If ret Then Set CopyBitmapPicture = ipic: Exit Function
With PictStructure: .cbSize = Len(PictStructure): .picType = 1: .hImage = hCopy: End With
ret = OleCreatePictureIndirect(PictStructure, tIID, 1, ipic)
If ret Then Set CopyBitmapPicture = ipic: Exit Function
Set CopyBitmapPicture = ipic
If lPath <> "" Then SavePicture ipic, lPath: Set ipic = Nothing
OpenClipboard 0: EmptyClipboard: CloseClipboard
End Function
'--------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------
'LA FONCTION POUR LE FORMAT PNG
Public Function CopyPngPicture(obj As Object, lPath As String, Optional RangeTransparency As Boolean = False) As Variant
'patricktoulon
Dim i&, hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte
If TypeName(obj) = "Range" Then
obj.CopyPicture ' on reste en xlpicture par defaut(la capture est de meilleure qualité)
obj.Parent.Paste 'on recole sur la feuille
If Not RangeTransparency Then
Selection.ShapeRange.Fill.ForeColor.RGB = vbWhite 'on mremet le fond en blanc
Selection.ShapeRange.Fill.Visible = True 'le fond est visible
End If
Selection.Copy 'on recopie la capture donc une image (copy tout court pour disposer des formats dans le clipboard)
Selection.Delete 'on peut supprimer l'image temporaire
Do Until IsClipboardFormatAvailable(14) > 0 Or i > 1000: i = i + 1: DoEvents: Loop
Else
obj.Copy 'si c'est une shapes , picture , ou tout autre object(sauf range) on copy tout court
End If
dataFormat = RegisterClipboardFormatW(StrPtr("PNG"))
If Not CBool(OpenClipboard(0)) Then MsgBox "L'Ouverture tu ClipBord a échoué": CopyPngPicture = False: Exit Function
If Not CBool(IsClipboardFormatAvailable(dataFormat)) Then MsgBox "Aucun Png dispo dans le clipboard": CopyPngPicture = False: Exit Function
hClipMemory = GetClipboardData(dataFormat)
If Not CBool(hClipMemory) Then MsgBox "Aucun Stream de Png dispo dans le clipboard": CopyPngPicture = False: Exit Function
memSize = GlobalSize(hClipMemory)
lpClipMemory = GlobalLock(hClipMemory)
If CBool(lpClipMemory) Then
ReDim tmpBuffer(0 To memSize - 1) As Byte
Call CopyMemory(VarPtr(tmpBuffer(0)), lpClipMemory, memSize)
apiRetVal = GlobalUnlock(hClipMemory)
Else
MsgBox " Récupération du STREAM du png a echoué": Exit Function
End If
Open lPath For Binary Access Write As #1: Put #1, 1, tmpBuffer: Close #1
CopyPngPicture = lPath
EmptyClipboard
CloseClipboard
End Function
Sub ListClipboardDisponibleFormats()
'patricktoulon
Dim formatID As Long
OpenClipboard 0
formatID = EnumClipboardFormats(0)
Do While formatID <> 0
Debug.Print "Format disponible : " & Hex(formatID)
formatID = EnumClipboardFormats(formatID)
Loop
CloseClipboard
End Sub
![](data:image/svg+xml;charset=utf-8,<svg height="485px" width="548px" xmlns="http://www.w3.org/2000/svg" version="1.1"/>)
![](data:image/svg+xml;charset=utf-8,<svg height="716px" width="1563px" xmlns="http://www.w3.org/2000/svg" version="1.1"/>)