'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'function de cature d'object(range, shapes ,pictures,etc) et sauvegarde en pngFile
'patricktoulon : basé sur le travail de Philipp Stiefel,https://codekabinett.com/rdumps.php?Lang=2&targetDoc=vba-clipboard-file-content
'jurassic pork
#If VBA7 Then
#If Win64 Then
' Déclarations pour VBA 7 64 bits
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 RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
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)
#Else
' Déclarations pour VBA7 32 bits
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
#Else
' Déclarations pour VBA 6 (32 bits uniquement)
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
'Sub testavecshape()
' SaveObjToPngFile ActiveSheet.Shapes("boule"), Environ("userprofile") & "\desktop\output.png"
'End Sub
'Sub testavecrange() 'ne fonctionne pas avec les range
' SaveObjToPngFile [A1:F5], Environ("userprofile") & "\desktop\output2.png" ', True'le 3eme argumen(true/false) pour laisser la transparence pour les range
'End Sub
Sub Export_Photos3()
sourceZip = ThisWorkbook.Path & "\zzz.zip"
destinationFolder = ThisWorkbook.Path & "\mes images"
If Dir(destinationFolder, vbDirectory) = "" Then MkDir destinationFolder
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("INVENDUS")
For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
If Not .Cells(i, 2).Comment Is Nothing Then
If .Cells(i, 2).Comment.Shape.Fill.Type = 6 Then
.Cells(i, 2).Comment.Visible = True
SaveObjToPngFile .Cells(i, 2).Comment.Shape, destinationFolder & "\" & .Cells(i, 2).Value & ".png"
.Cells(i, 2).Comment.Visible = False
End If
End If
Next
End With
End Sub
Public Function SaveObjToPngFile(obj As Object, lPath As String, Optional RangeTransparency As Boolean = False) As Variant
Dim i&, hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte
obj.CopyPicture ' on reste en xlpicture par defaut(la capture est de meilleure qualité)
ActiveSheet.Paste 'on recole sur la feuille
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
dataFormat = RegisterClipboardFormatW(StrPtr("PNG"))
If Not CBool(OpenClipboard(0)) Then MsgBox "L'Ouverture tu ClipBord a échoué": SaveObjToPngFile = False: Exit Function
If Not CBool(IsClipboardFormatAvailable(dataFormat)) Then MsgBox "Aucun Png dispo dans le clipboard": SaveObjToPngFile = False: Exit Function
hClipMemory = GetClipboardData(dataFormat)
If Not CBool(hClipMemory) Then MsgBox "Aucun Stream de Png dispo dans le clipboard": SaveObjToPngFile = 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: lWritePos = 1: Put #1, 1, tmpBuffer: Close #1
SaveObjToPngFile = lPath
EmptyClipboard
CloseClipboard
End Function