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

[patricktoulon]

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

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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

 

[patricktoulon]

re
Bonjour jurassic pork
c'est exactement ce que j'ai fait par contre les gestion d'attente arbitraire je fait pas je fait une gestiond d'attente du bitmap dans le clip

'Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
'Private Declare Function CloseClipboard Lib "user32" () As Long
'Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As LongPtr) 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&, 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 PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
#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 i&, hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte

    If TypeName(obj) = "Range" Then
        obj.CopyPicture Format:=xlBitmap
        obj.Parent.Paste
        Selection.Copy
        Selection.Delete
        Do While IsClipboardFormatAvailable(&H2) = 0 Or i = 2000: i = i: DoEvents: Loop
    Else
        obj.Copy
    End If
    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

 

[jurassic pork]

Hello Patrick,
tester le bitmap dans le presse-papier ça ne sert à pas grand chose si il y a un plantage comme j'ai parfois sur les copy. En fait si il y a un plantage sur un copyPicture ou copy ou paste il faut réessayer l'action. Et dans les boucles mettre des tempos (Sleep) pour ne pas bouffer du CPU.

 

[patricktoulon]

re
il y a les 3 tests après qui font leur travail respectif
par contre avec cette methode on a pas les dimensions réelles
en wmf les captures se font en dimension 200%

ça sert à rien de recommencer infiniment et de décider une limite arbitraire qui sera bonne chez toi et peut être pas chez un autre
d'autant plus que le sleep gèlent les procc et donc ralentissent le processus
essai avec ma méthode tu verra
c'est un exemple concret ou l'on voit que un do/loop sur quelque chose avec doevents est plus adapté au contexte des que isavailableformat est choppé hop on y va
tandis qu'avec un sleep deja tu ralenti et si c'est pas bon tu recommence et tu ralenti encore

pour info chez moi c'est quasi instantané avec ta méthode j'ai essayé(par curiosité bien que je savais)
et effectivement
essaie 3 fois et une a a recommencé

après dans le code on a 3 tests il font leur job
mon do/loop compte jusqu’à 2000 c'est a dire a peu près 1 sec et 700 centièmes
c'est largement suffisant
si la copy n'est pas faite apres ça il c'est passé un soucis il est pour moi inutile de mouliner

tu peux augmenter le 2000 si tu veux mais dans tout les cas c'est soit on arrive au compte de I , soit on sort avant et le bitmap est là

je l'ai constaté ça surtout avec le travail de gestion d'attente sur l'exploration html avec ie
les sleep ralentissent
je suis d’accords sur le fait que effectivement ça t'apporte une certaine sécurité d'obtention mais au prix d'un ralentissement a minima du plus grand sleep+ sa conséquence du au gel des procc

essaie avec ma méthode tu verra la différence( fait moi plaisir)

 

[patricktoulon]

pour te la faire courte
là ou toi tu fait un sleep 20
moi je vais faire au moins 25 tests availableformat et il est certain que si c'est bon je vais sortir avant
et pour peu que ca se passe entre deux sleep chez toi ,ben toi tu attendra 40 et plus

 

[jurassic pork]

Regarde dans le gestionnaire de tâche l'utilisation CPU pendant une boucle sans le sleep . et le sleep permet de régler un temps exact tandis qu'une boucle sans sleep dépend de la vitesse cpu

 

[patricktoulon]

ben oui c'est justement ça le problème
la vitesse du cpu va varier selon l'occupation des autres taches du Pc

avec ma méthode on sort dès que c'est bon et pas un sleep après
dans tout les cas les exemples de situations similaire m'ont prouvé que c’était plus rapide comme ça
après peut être qu'il y a des situations qui exigeront des pauses je sais pas
je n'ai pas encore trouvé d'exemple qui contredisent mon raisonnement

fait moi plaisir essaie tu verra

c'est simple tu fait un sleep 100 puis des sleep 20 donc a minima 1sec 20
moi je compte jusqu'a 2000 soit 1 sec et 700 centième sauf que je sort dès que c'est bon
le doevents est là pour laisser le travail se faire en arrière plan
j'ai mesuré avec une variable ta méthode et la mienne
je sort avec i qui est egale a entre 300/400 soit l’équivalent a peu près d'un sleep 25/35
avec ta methode je sort a minima 1 sec et un peu sur 4 essais après le sleep 100 on a 3 fois sur 4 l'image il faut un 20 de plus conclusion
si tout se passe bien
patosh 30/35
jurassic pork 120
et pour le coup crois moi je suis sur de moi là

les sleep c'etait bien quand on avaient des pc brouette et proc mono corps ca permettait au clip de se charger en gelant le procc mais aujourd'hui ca n'a plus de sens tout du moins comme tu l'entends
entendons nous bien ca peut servir je n'en doute pas pour faire une pause d'une durée décidée à l'avance mais dans le cadre d'une attente d'une valeur un test infini avec sortie dès que c'est bon avec une sorti temps maximal est beaucoup mieux c'est pas joli je te l'accorde mais une chose est sur c'est plus rapide

 

[jurassic pork]

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

je viens de découvrir la fonction CallByName :

Exécute une méthode d’un objet, ou définit ou renvoie une propriété d’un objet.
Syntaxe
CallByName (object, procname, calltype, [args()]_)
La syntaxe de la fonction CallByName comprend les arguments nommés suivants :
Élément Description
object Obligatoire : Variant (Object). Nom de l’objet sur lequel la fonction sera exécutée.
procname Obligatoire : Variant (String). Expression de chaîne contenant le nom d’une propriété ou d’une méthode de l’objet .
calltype Obligatoire : constante. Constante de type vbCallType représentant le type de procédure appelée.
args() Facultatif : Variant (Array).

Grace à elle j'ai pu créer une fonction qui fait des essais sur une méthode tant qu'il y a des erreurs :

Function retryMethod(Obj As Object, MethodName, NbArgs, Optional Arg1, Optional Arg2, Optional Arg3)
Dim retryCount As Integer
retryCount = 0
retry:
                On Error GoTo ErrorHandler
                Select Case NbArgs
                    Case 0
                          retryMethod = CallByName(Obj, MethodName, VbMethod)
                     Case 1
                          retryMethod = CallByName(Obj, MethodName, VbMethod, Arg1)
                     Case 2
                          retryMethod = CallByName(Obj, MethodName, VbMethod, Arg1, Arg2)
                     Case 3
                          retryMethod = CallByName(Obj, MethodName, VbMethod, Arg1, Arg2, Arg3)
                End Select
                GoTo Fin
        
ErrorHandler:
                retryCount = retryCount + 1
                If retryCount <= 10 Then
                    'Sleep 20
                    Debug.Print "Retry " & MethodName & " : "; retryCount & " - Erreur: " & Err.Number
                    Resume retry
                Else
                    MsgBox "Erreur  Méthode " & MethodName & " essayée 10 fois."
                    Exit Function
                End If
Fin:
End Function

et voici comment je l'utilise dans ma macro :

Sub GetRangeClipboardBoucle()
' J.P Novembre 2024
Dim buffer() As Byte, lWritePos As Integer, data, TextData As String
Dim formats As String
Application.CutCopyMode = False
'ActiveSheet.Range("A1:J20").CopyPicture xlScreen, xlBitmap
'ActiveSheet.Paste
'Selection.Copy
retryMethod ActiveSheet.Range("A1:J20"), "CopyPicture", 2, xlScreen, xlBitmap
retryMethod ActiveSheet, "Paste", 0
retryMethod Selection, "Copy", 0
Selection.Delete
formats = ClipBoardJP.GetAvailableClipBoardFormats
'Debug.Print formats
buffer = retryMethod(ClipBoardJP, "GetData", 1, "PNG")
Application.CutCopyMode = False
Open "d:\temp\range.png" For Binary Access Write As #1
lWritePos = 1
Put #1, lWritePos, buffer
Close #1
End Sub

Dans ce programme de test en boucle sur 1000 itérations :

Sub TestBoucle()
Dim i
For i = 1 To 1000
   GetRangeClipboardBoucle
Next i
Debug.Print "Fin Boucle"
End Sub

je n'ai pas de plantage parfois un retry Exemple :

Retry Paste : 1 - Erreur: 1004
Retry GetData : 1 - Erreur: 440
Fin Boucle

 

[jurassic pork]

Do While IsClipboardFormatAvailable(&H2) = 0 Or i = 2000: i = i: DoEvents: Loop

Dis moi Patrick, tu nous ressors souvent ce genre de boucle avec la même erreur : i = i ben avec ça c'est sûr que i ne va jamais atteindre 2000. Il va falloir revoir tes archives .

 

[patricktoulon]

re
Bonsoir jurassic pork
ben tu vois je n'ai pas vu l'erreur et pourtant je n'ai aucun raté sur les captures
ça prouve bien que le do/loop sur le availableformat avec un doevents est largement suffisant
je l'ai même reduit a 1000

   Do Until IsClipboardFormatAvailable(&H2) > 0 Or i > 1000: i = i + 1: DoEvents: Loop

 

[jurassic pork]

entendons nous bien ca peut servir je n'en doute pas pour faire une pause d'une durée décidée à l'avance mais dans le cadre d'une attente d'une valeur un test infini avec sortie dès que c'est bon avec une sorti temps maximal est beaucoup mieux c'est pas joli je te l'accorde mais une chose est sur c'est plus rapide

Hello,
Pour voir tout cela j'ai fait un essai de performance avec des boucles :
1 - 1000 boucles à vide
2 - 1000 boucles avec un DoEvents
3 - Utilisation du Timer pour boucler jusqu'à 50 ms
4,5,6 La même chose mais avec une fonction de test de présence de format PNG dans le presse-Papier dans la boucle.

Sub TestVitesseBoucle()
Dim i As Long
Dim bm As New cBenchmark
Dim startTime As Single
bm.TrackByName "INIT"
Application.CutCopyMode = False
ActiveSheet.Shapes("Coeur").Copy
For i = 1 To 1000
Next i
bm.TrackByName "Boucle de 1000 sans Rien"
For i = 1 To 1000
DoEvents
Next i
bm.TrackByName "Boucle de 1000 avec DoEvents"
startTime = Timer
Do While Timer - startTime < 0.05
DoEvents
Loop
bm.TrackByName "Loop Timer 50ms avec DoEvents"
For i = 1 To 1000
WaitMethod ClipBoardJP, "IsFormatAvailable", 1, "PNG"
Next i
bm.TrackByName "Boucle de 1000 WaitMethod"
For i = 1 To 1000
WaitMethod ClipBoardJP, "IsFormatAvailable", 1, "PNG"
DoEvents
Next i
bm.TrackByName "Boucle de 1000 WaitMethod avec DoEvents"
startTime = Timer
Do While Timer - startTime < 0.05
WaitMethod ClipBoardJP, "IsFormatAvailable", 1, "PNG"
DoEvents
Loop
bm.TrackByName "Loop Timer 50ms WaitMethod avec DoEvents"

Résultats sur mon Ordinateur (Intel(R) Core(TM) i5-10400 CPU @ 2.90GHz 16 Go Ram Windows 11 Excel 2019 32 bits) :

IDnr​	Name​	Count​	Sum of tics​	Percentage​	Time sum​
0​	INIT	1​	304​	0,01%	30 us
1​	Boucle de 1000 sans Rien	1​	8680​	0,36%	868 us
2​	Boucle de 1000 avec DoEvents	1​	614606​	25,18%	61 ms
3​	Loop Timer 50ms avec DoEvents	1​	531803​	21,79%	53 ms
4​	Boucle de 1000 WaitMethod	1​	101194​	4,15%	10 ms
5​	Boucle de 1000 WaitMethod avec DoEvents	1​	599640​	24,57%	60 ms
6​	Loop Timer 50ms WaitMethod avec DoEvents	1​	584490​	23,95%	58 ms
TOTAL	7​	2440717​	100,00%	244 ms
Total	time recorded: 244 ms

La solution la meilleure semble être celle du Timer qui est la plus précise quelque soit le CPU (sinon il faut ajuster la boucle à la vitesse de son CPU)
A noter aussi que j'ai fait un essai de test du format PNG présent dans le presse-papier juste après un shape.copy sur une boucle de 1000 essais , sur mon ordinateur je n'ai jamais d'attente
le PNG est disponible tout de suite sur l' instruction WaitMethod :

retryMethod Selection, "Copy", 0
WaitMethod ClipBoardJP, "IsFormatAvailable", 1, "PNG"

Avec WaitMethod :

Function WaitMethod(obj, MethodName, NbArgs, Optional Arg1, Optional Arg2, Optional Arg3) As Boolean
Dim i As Integer
i = 0
Do Until i > 100
                On Error GoTo ErrorHandler
                Select Case NbArgs
                    Case 0
                          WaitMethod = CallByName(obj, MethodName, VbMethod)
                     Case 1
                          WaitMethod = CallByName(obj, MethodName, VbMethod, Arg1)
                     Case 2
                          WaitMethod = CallByName(obj, MethodName, VbMethod, Arg1, Arg2)
                     Case 3
                          WaitMethod = CallByName(obj, MethodName, VbMethod, Arg1, Arg2, Arg3)
                End Select
                If WaitMethod Then Exit Function
                i = i + 1
                Debug.Print "WAIT " & i
Loop
TimeOut:
     MsgBox "TimeOut Méthode " & MethodName
     Exit Function
ErrorHandler:
     MsgBox "Erreur  Méthode " & MethodName & " - Erreur: " & Err.Number
End Function

je n'ai pas de WAIT <i> qui s'affiche

Ami calmant, J.P

 

[patricktoulon]

re
Bonjour jurassic pork
moi non plus la boucle d'attente est inutile chez moi elle est là pour ceux qui eventuellement aurait des soucis de latence avec le clipboard

après il faut bien comprendre que 1000 c'est une limite acceptable selon moi, au delà on sort
c'est juste un fusible mais il ne détermine pas le temps d'attente
j'ai mis le test benchmark à chaque etape

le test avec un timer après le do loop donne 0,00000 Sec tout le temps
chez moi je peux donc même mettre ce do loop en commentaire

 

[patricktoulon]

re
Bonsoir @jurassic pork
juste pour donner la version finale
du coup je ne copy pas en xlbitmap(tres mauvaise qualité)
je reste en xlpicture mais pour les range avec des cellule interior.color xlnone je remet le fillvisible a true sur l'image collée
bien sur c'est optionnel
j'ai une qualité exellente
et en plus le poids du fichier final passe de 32.4 kilo à 1.73 kilo autant te dire que c'est tout benef

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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()
    SaveObjToPngFile [A1:F5], Environ("userprofile") & "\desktop\output2.png" ', True'le 3eme argumen(true/false) pour laisser la transparence pour les range
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

    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é": 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

démo de la plage capturée zoomée 200 % en haut xlpicture en bas xlbitmap