XL 2013 enregistrer la capture d'une shape avec les api avec transparence

patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonjour a tous
je met un peu a jour mon xlam utilitaire
et parmis ces fonctions j'en ai une avec les api qui me permet d'enregistrer une shape avec les api et GDI+ en format png
sauf que la capture se fait en bitmap il est donc clair que je n'aurais pas la transparence au moins dans les place vide qu'occupe le rectangle d'une shape quel que soit sa forme
même si elle est bien utile j'aimerais trouver le bon code pour garder les partie transparente et non sur un fond blanc
voi ma fonction
pour le coup je l'ai remis un peu au propre
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'capturer une plage ou shape ou picture en bitmap et créer un fichier image en png
'patricktoulon exceldownloads
'utilisation d'un  clisd pour la structure IPictureIID png
'date 04/06/2016
'code remastered  date: 09/11/2024
'abandon du vb6
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, inputbuf As Any, ByVal outputbuf As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hpal As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, ByVal filename As LongPtr, clsidEncoder As Any, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal strCLSID As LongPtr, ByRef pClsid As GUID) As Long

Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Function CopyPngPicture(obj As Object, lPath As String)
    Dim hCopy As LongPtr, token As LongPtr, bitmap As LongPtr, CLSID_PNG As GUID, StartupInput As GdiplusStartupInput

    StartupInput .GdiplusVersion = 1 ' Démarrer GDI+

    If GdiplusStartup(token, StartupInput, 0&) <> 0 Then Exit Function 'si GDI+ n'est pas ok on sort

    obj.CopyPicture format:=xlBitmap ' Copier l'image en Bitmap

    OpenClipboard 0 'ouverture clipboard

    hCopy = GetClipboardData(&H2) 'recupération du handle du bitmap dans le clipboard

    CloseClipboard 'fermeture clipboard

    If hCopy = 0 Then GoTo byebye ' si pas de handle bitmap on se casse

    If GdipCreateBitmapFromHBITMAP(hCopy, 0&, bitmap) <> 0 Then GoTo byebye ' Créer un bitmap GDI+ à partir du handle hcopy

    CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), CLSID_PNG ' Obtenir le CLSID en longPtr pour le format PNG

    If GdipSaveImageToFile(bitmap, StrPtr(lPath), CLSID_PNG, 0&) <> 0 Then GoTo byebye ' Enregistrer l'image au format PNG

byebye:
    ' comme ça n'a pas fonctionner  alors un coup pelle aux variables
    If bitmap Then GdipDisposeImage bitmap
    GdiplusShutdown token
End Function
 
Trier par date Trier par votes
patricktoulon

patricktoulon

XLDnaute Barbatruc
j'ai ce code là qui ne fonctionne pas j'ai une erreur de convention d'appel sur la dll avec la fonction GdipDrawImageRectRectI

VB: 
Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus.dll" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, ByVal outputbuf As LongPtr) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus.dll" (ByVal token As LongPtr)
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "GDIPlus.dll" (ByVal width As Long, ByVal height As Long, ByVal stride As Long, ByVal pixelformat As Long, ByVal scan0 As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "GDIPlus.dll" (ByVal image As LongPtr, ByRef graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus.dll" (ByVal image As LongPtr, ByVal filename As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus.dll" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "GDIPlus.dll" (ByVal graphics As LongPtr) As Long

Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "GDIPlus.dll" (ByVal graphics As LongPtr, ByVal image As LongPtr, ByVal dstx As Long, _
                              ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, _
                              ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long) As Long

'declaration trouvé sur le net
'Private Declare Function GdipDrawImageRectRectI Lib "GDIPlus.dll" (ByVal graphics As Long, ByVal pImage As Long, ByVal dstx As Long, _
                              ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, _
                              ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, _
                              ByVal imageAttributes As Long, ByVal pcallback As Long, ByVal callbackData As Long) As Long

Sub test()
    SaveShapeAsPNGWithTransparency ActiveSheet.Shapes("boule"), Environ("userprofile") & "\desktop\noule.png"
End Sub

Function SaveShapeAsPNGWithTransparency(shap As shape, lPath As String)
    Dim token As LongPtr, bitmap As LongPtr, graphics As LongPtr
    Dim CLSID_PNG As GUID
    Dim StartupInput As GdiplusStartupInput
    Dim width As Long, height As Long

    ' Initialiser GDI+
    With StartupInput
        .GdiplusVersion = 1
    End With
    If GdiplusStartup(token, StartupInput, 0&) <> 0 Then Exit Function

    ' Déterminer les dimensions de l'image
    width = shap.width
    height = shap.height

    ' Créer un bitmap avec canal alpha (transparence)
    If GdipCreateBitmapFromScan0(width, height, 0, &H26200A, 0, bitmap) <> 0 Then GoTo ByeBye

    ' Créer un contexte graphique pour dessiner la Shape
    If GdipGetImageGraphicsContext(bitmap, graphics) <> 0 Then GoTo ByeBye

    ' Dessiner la Shape dans le contexte graphique (supportant la transparence)
    shap.Copy
    If GdipDrawImageRectRectI(graphics, bitmap, 0, 0, width, height, 0, 0, width, height, 0) <> 0 Then GoTo ByeBye

    ' Obtenir le CLSID pour le format PNG
    CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), CLSID_PNG

    ' Enregistrer l'image avec transparence au format PNG
    If GdipSaveImageToFile(bitmap, StrPtr(lPath), CLSID_PNG, 0&) <> 0 Then GoTo ByeBye

ByeBye:
    MsgBox "au revoir"
    ' Libérer les ressources
    If graphics Then GdipDeleteGraphics graphics
    If bitmap Then GdipDisposeImage bitmap
    GdiplusShutdown token
End Function

si quelqu'un sait ?...
 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
Bonjour le fil, @patricktoulon
Voici un code à adapter qui permet de copier une shape (ici la 1ère) en fichier png avec la transparence.

VB: 
Sub CopyShapeBmp()
Dim MemoGrille As Boolean       ' Pour rétablir la grille telle qu'elle
Dim NomFichierImage As String   ' Chemin complet d'enregistrement de l'image
Dim NoShape As Integer
    NomFichierImage = "C:\Users\Crocrocro\Documents\MaShape1.png"

    Application.ScreenUpdating = False
    MemoGrille = ActiveWindow.DisplayGridlines
    ActiveWindow.DisplayGridlines = False

    ' Création d'une zone de graphique pour y copier la shape
    ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
    NoShape = ActiveSheet.Shapes.Count
    ' Redimentionnement à la taille de la shape à copier
    ActiveSheet.Shapes(NoShape).Height = ActiveSheet.Shapes(1).Height
    ActiveSheet.Shapes(NoShape).Width = ActiveSheet.Shapes(1).Width
    ActiveSheet.Shapes(NoShape).Fill.Visible = msoFalse
    ActiveSheet.Shapes(1).Copy
    ActiveChart.Paste

    ' Export en image png
    ActiveChart.Export filename:=NomFichierImage, FilterName:="PNG"

    ActiveSheet.Shapes(NoShape).Delete
    ActiveWindow.DisplayGridlines = MemoGrille
    Application.ScreenUpdating = True

End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour @crocrocro
merci pour l'intérêt que tu porte a mon exo
mais je connais déjà cette astuce du chart avec le font transparent(ET PAS EN NO VISIBLE !!!!!!) j'avais fait d'ailleurs une ressource avec cette méthode
pour te la faire courte sans le fill visible certain app dessin ouvre l'image avec un fond noir par ce qu'il manque le calque il faut qu'il soit true mais transparent
je te renvoie donc ici
excel-downloads.com

une fonction pour capturer un object dans une feuille en png avec un graphique qui marche vraiment

Bonjour à tous tout le monde connait le principe de capture et d'enregistrement d'un object sur feuille en fichier image alors les format possible jpg,gif,png le tout avec un graphique sauf que le format gif et png sont particuliers et...
excel-downloads.com excel-downloads.com

sauf que avec le chart , dans certaines circonstances encore obscures pour moi on a une erreur sur le chart avec les versions récentes de excel d'après des retours sur DVP(cela dit avec ma version je n'ai jamais eu de soucis)

je veux vraiment le faire avec les api gdi et ou gdi+ pour finaliser cette rubrique dans mon utilitaire xlam
 
Vote positif 0 Vote négatif
C

crocrocro

XLDnaute Occasionnel
patricktoulon à dit:
mais je connais déjà cette astuce du chart avec le font transparent(ET PAS EN NO VISIBLE !!!!!!) j'avais fait d'ailleurs une ressource avec cette méthode
Cliquez pour agrandir...
avec ActiveSheet.Shapes(NoShape).Fill.Visible = msoFalse comme je le propose, la portion vide du rectangle est bien transparente, l'intérieur de la shape est normale
avec ce que tu indiques ActiveSheet.Shapes(NoShape).Fill.Transparency = 1, (si j'ai bien compris), la portion vide du rectangle est blanche, l'intérieur de la shape est normale.
Testé avec Gimp que tu connais ;)
EDIT : Idem avec la visionneuse windows.
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
ben chez moi c'est exactement le contraire
si je met fill.visible=msofalse le font est noir
après gimp est quand même puissant peut être qu'il a des trucs en plus mais d'autres app voir simplement la visionneuse on a un fond noir d'ailleurs dans la video de la ressource j'en fait la démo
attention le fill doit être solid !!!!! pour le garder comme calque Alpha dans le png
 
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
patricktoulon à dit:
j'ai ce code là qui ne fonctionne pas j'ai une erreur de convention d'appel sur la dll avec la fonction GdipDrawImageRectRectI

si quelqu'un sait ?...
Cliquez pour agrandir...
Hello,
il y a un de tes paramètres de la fonction qui n'est pas bon le dernier qui est à 0 il devrait être à 2 ( unité pixel).
D'autre part je n'ai pas trop compris pourquoi tu fais un shap.Copy car ceci ne met la forme que dans le presse-papier Le
VB: 
GdipDrawImageRectRectI(graphics, bitmap, 0, 0, width, height, 0, 0, width, height, 2)
Va ne faire que copier l'image créée dans le context donc une image noire . Par contre si l'on fait ceci :
Code: 
res = GdipLoadImageFromFile(StrPtr("d:\temp\cercle.png"), Image)
    res = GdipDrawImageRectRectI(Graphics, Image, 0, 0, width, height, 0, 0, width, height, 2)
Cela va bien copier un bout de l'image provenant du fichier image dans le bitmap .
J'ai fait l'essai avec un fichier Image contenant une image avec de la transparence, le fichier sauvegardé à la fin du code a bien la transparence.
Ami calmant, J.P
 
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
une piste :
quand je copie une forme avec transparence dans Excel et que je la colle dans le classeur ou dans un classeur LibreOffice la transparence est préservée, donc cela veut dire que dans le presse-papier on a les bonnes données quelque part. Si on regarde l'intérieur du presse-papier quand on copie une forme on a ceci :
XlShapeClipboard.png

on remarque qu'il y a un format propriétaire PNG ( 49458) . Il faudrait essayer de récupérer les données de ce format et les sauvegarder dans un png pour voir.
[EDIT] Confirmer par collage spécial dans Excel : c'est quand on choisit le format PNG qu'on a la transparence. Et quand dans Excel on colle dans un objet chart , c'est bien la version avec transparence qui est collée.
 
Dernière édition:
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
En tout cas moi cela fonctionne maintenant avec ma nouvelle version de ma dll dotnet où j'ai rajouté pour le presse-papier la fonction SaveDataTofile :
VB: 
Sub SauveForme()
Dim pp As Object, dataObject As Object
Set pp = CreatePressePapierClass()
pp.Clear
Worksheets("Formes").Shapes("Cercle").Copy
'on sauvegarde les données d'un format du pressepapier dans un fichier
pp.SaveDataToFile "PNG", "d:\tmp\dataObject.png"
End Sub
Voici ce que j'obtiens avec une forme Cercle dans Excel avec un fond transparent et de la transparence dans la couleur de remplissage :
dataObject.png


On doit pouvoir faire la même chose en VBA Le principe : dans le clipboard on fait un getData pour le format "PNG" (on est pas obligé de mettre un nombre) on récupère une memorystream et on écrit la memorystream dans un fichier. Dans le presse-papier en fait il y a le binaire PNG :

PP_PNG.png


Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
Hello,
finalement j'ai fini par découvrir un module de classe ici (clipboard.cls créé par Philipp Stiefel) qui simplifie grandement l'extraction de données à partir du presse-papier.
Voici par exemple comment sauvegarder une forme Excel en format PNG, JPEG, GIF en passant par le presse-papier :
VB: 
Sub GetDataPP()
Dim buffer() As Byte, lWritePos As Integer
Dim formats As String
ActiveSheet.Shapes("Cercle").Copy
formats = Clipboard.GetAvailableClipBoardFormats
Debug.Print formats
buffer = Clipboard.GetData("PNG")
Open "d:\temp\output.png" For Binary Access Write As #1
lWritePos = 1
Put #1, lWritePos, buffer
Close #1
buffer = Clipboard.GetData("GIF")
Open "d:\temp\output.gif" For Binary Access Write As #1
lWritePos = 1
Put #1, lWritePos, buffer
Close #1
buffer = Clipboard.GetData("JFIF") 'Le JFIF c'est en fait du JPEG
Open "d:\temp\output.jpeg" For Binary Access Write As #1
lWritePos = 1
Put #1, lWritePos, buffer
Close #1
End Sub
Il y a quelques modifications à faire pour le rendre compatible Excel 64 bits :
1 - Il faut enlever l'option Option Compare Database
2 - Changer les déclarations d'API
VB: 
Option Explicit
Private Const CLASS_NAME As String = "Clipboard"
'Philipp Stiefel September 2019
'Updated by Jurassic Pork for 64 bits compatibility November 2024

'API Declarations:
#If VBA7 Then
  Private Declare PtrSafe Function EmptyClipboard Lib "User32" () 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 Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function lstrcpyA Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
  Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal Format As Long) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipBoardData Lib "User32" Alias "GetClipboardData" (ByVal Format As Long) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
  Private Declare PtrSafe Function EnumClipboardFormats Lib "User32" (ByVal Format As Long) As Long
  Private Declare PtrSafe Function GetClipboardFormatNameW Lib "User32" (ByVal Format As Long, ByVal lpszFormatName As LongPtr, ByVal cchMaxCount As Long) As Long
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
  Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
  Private Declare PtrSafe Function lstrlenA Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
  Private Declare PtrSafe Function RegisterClipboardFormatA Lib "kernel32" (ByVal lpString As String) As Long
  Private Declare PtrSafe Function RegisterClipboardFormatW Lib "User32" (ByVal lpszFormat As LongPtr) As Long
#Else
  Private Declare Function EmptyClipboard Lib "User32" () 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 Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function lstrcpyA Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
  Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
  Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal Format As Long) As Long
  Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
  Private Declare Function GetClipBoardData Lib "User32" Alias "GetClipboardData" (ByVal Format As Long) As Long
  Private Declare Function CloseClipboard Lib "User32" () As Long
  Private Declare Function EnumClipboardFormats Lib "User32" (ByVal Format As Long) As Long
  Private Declare Function GetClipboardFormatNameW Lib "User32" (ByVal Format As Long, ByVal lpszFormatName As Long, ByVal cchMaxCount As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
  Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
  Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
  Private Declare Function GetTickCount Lib "kernel32" () As Long
  Private Declare Function RegisterClipboardFormatA Lib "kernel32" (ByVal lpString As String) As Long
  Private Declare Function RegisterClipboardFormatW Lib "User32" (ByVal lpszFormat As Long) As Long
#End If
En tout cas cela fonctionne chez moi avec Excel 2019 32 bits et Excel 2021 64 bits

Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonsoir jurassic pork
c'est vraiment pas mal du tout ça
sauf que visiblement quand je copie une plage le stream du png n'est pas dispo
je me suis fait ma petite fonction avec
VB: 
'#If VBA7 Then

'#Else
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipBoardData Lib "User32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal Format As Long) As Long
Private Declare Function RegisterClipboardFormatW Lib "User32" (ByVal lpszFormat 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)


'#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"
End Sub


Public Function SaveObjToPngFile(obj As Object, lPath As String) As Variant
    Dim hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte

    obj.Copy

    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

    CloseClipboard

End Function
 
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
hello Patrick,
Pour les plages , Il faut que tu regardes de quoi tu disposes en listant les formats contenus dans le presse-papier (ce que je fais au début de mon code), il n'y a pas de PNG , je crois qu'il n'y a en image que du bitmap. Il ne faut pas tenter de récupérer quelque chose qui n'est pas présent.
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re il faudra tester
VB: 
#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 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 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"
End Sub


Public Function SaveObjToPngFile(obj As Object, lPath As String) As Variant
    Dim hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte

    obj.Copy

    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

    CloseClipboard

End Function
 
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
Hello,
en fait pour récupérer une version bitmap d'une plage dans le presse-papier il faut faire un copypicture comme ceci par exemple :
VB: 
ActiveSheet.Range("A1:C2").CopyPicture xlScreen, xlBitmap
Le souci c'est qu'on se retrouve dans le presse-papier avec des formats DIB (DIB et DIBV5)
On arrive à lire ces données mais comment les convertir dans un format image classique ?
J'ai trouvé un autre moyen en collant le contenu du presse-papier alors dans la feuille puis on copie la sélection dans le presse-papier et là on se retrouve avec du format PNG que l'on peut récupérer :
Code: 
Application.CutCopyMode = False
ActiveSheet.Range("A1:C2").CopyPicture xlScreen, xlBitmap
ActiveSheet.Paste
Selection.Copy
Selection.Delete
formats = ClipBoardJP.GetAvailableClipBoardFormats
Debug.Print formats
buffer = ClipBoardJP.GetData("PNG")
Le souci avec cette méthode c'est qu'il y a un problème de timing qui peut faire échouer la méthode Paste ou Copy.
En Rajoutant des tempos je n'ai pas l'air de planter :
VB: 
Application.CutCopyMode = False
ActiveSheet.Range("A1:C2").CopyPicture xlScreen, xlBitmap
Sleep 100
ActiveSheet.Paste
Sleep 100
Selection.Copy
Selection.Delete
'ActiveSheet.Range("A1:C2").Copy
formats = ClipBoardJP.GetAvailableClipBoardFormats
Debug.Print formats
buffer = ClipBoardJP.GetData("PNG")
A Ajuster.
[EDIT] dans un test en boucle j'ai parfois des erreurs sur le CopyPicture.
Avec ce code :
VB: 
Dim retryCount As Integer
retryCount = 0
Application.CutCopyMode = False
retry_CopyPicture:
                On Error GoTo ErrorHandler
                ActiveSheet.Range("A1:H20").CopyPicture xlScreen, xlBitmap
                GoTo ContinueExecution
        
ErrorHandler:
                retryCount = retryCount + 1
                If retryCount <= 10 Then
                    Sleep 20
                    Debug.Print "Retry " & retryCount
                    Resume retry_CopyPicture
                Else
                    MsgBox "Error while trying to copy the picture 10 times. Macro Aborts."
                    Exit Sub
                End If
        
ContinueExecution:
ActiveSheet.Paste
j'ai parfois un ou deux retry mais cela passe et c'est peut être ce qu'il faut faire aussi sur le paste et le copy qui suivent au lieu de mettre une tempo. Peut-être inventer une fonction du genre :
RetryInstruction("Instruction à essayer", nbfois max)

Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

patricktoulon
  • Résolu(e)
XL 2013 prise de tête avec une variable static
Réponses
3
Affichages
355
patricktoulon
patricktoulon
R1-
  • Question
XL 2016 Impossible de SendKeys une tabulation
Réponses
4
Affichages
573
R1-
R1-
C
  • Question
XL 2019 Probleme olepro32 et/ou LongPtr
Réponses
11
Affichages
621
patricktoulon
patricktoulon
patricktoulon
  • Résolu(e)
XL 2013 icon avec une image Mso dans la barre de titre du UserForm
Réponses
10
Affichages
1 K
patricktoulon
patricktoulon
patricktoulon
  • Question
Autres l'api findwindow
2
Réponses
24
Affichages
2 K
Dranreb
Dranreb
Dudu2
  • Suggestion
Texte Définir les propriétés d'une cellule ou d'un Range (couleurs, fonte, ..., valeur) dans une formule
Réponses
0
Affichages
906
Dudu2
Dudu2
PHV.FSM
  • Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicolas JACQUIN
Nicolas JACQUIN
F
  • Question
Microsoft 365 UserForm maximiser la taille du formulaire par rapport à la taille de l'écran
2
Réponses
22
Affichages
2 K
TooFatBoy
TooFatBoy
R
  • Question
XL 2019 Convertir Macro 32 bit en 64 bit
Réponses
2
Affichages
3 K
sylvanu
sylvanu
treza88
  • Question
XL 2016 Modification code pour compatibilité 32 64 bit VBA7
2
Réponses
16
Affichages
4 K
Dranreb
Dranreb

Membres actuellement en ligne

3 membres et 47 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 729
Messages
2 112 268
Membres
111 481
dernier inscrit
zrk