capture ecran ou portion d'ecran avec les methode BitBlt et printwindow

Les Méthodes de Capture UserForm hyper rapides
by Patrick Toulon

Nous utiliserons ici les api principales BitBlt et PrintWindow. Nous allons voir les avantages et inconvénients entre l'une et l'autre. Nous verrons aussi comment découper ,stretcher l'image directement en mémoire avec BitBlt En fin fin de fiche je propose aussi une fonction Crop et zoom avec l'api StretchBlt qui permet aussi de stretcher ou decouper ou zoomer l'image capturée directement en mémoire Tout en bas Vous avez un tableau comparatif résumant les possibilités, Avantages et inconvénients

un fichier exécutant toute les versions est à dispos
avec un userform et des boutons affiliées aux diverses méthodes
-------------------BitBlt----------------------------------------PrintWindow--------------

Sommaire des fonctions

Snapshot_BITBLT_clip
Snapshot_BITBLT_clip2
Snapshot_BITBLT_ToFile1
Snapshot_BITBLT_FILE2
SnapShot_PW_FormToCLIP
SnapShot_PW_FormToFile
CropAndZoomClipboardBitmap
Tableau compartif

Snapshot_BITBLT_clip
Capture visible via BitBlt et envoi direct dans le presse-papiers (CF_BITMAP).
✔️ Inclus les effets visuels DWM
❌ Nécessite que la fenêtre soit visible

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                                       FONCTION  DE CAPTURE USERFORM
'auteur: patricktoulon
'dans cette version on utilise BitBlt et on met le bitmap dans le clipboard

Option Explicit

#If VBA7 then
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    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 SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP As Long = &H2

Public Sub Snapshot_BITBLT_clip(uF As Object)
    Dim r As RECT, hSrcDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr, hOldBmp As LongPtr, LARGEUR As Long, HAUTEUR As Long
    ' Obtenir dimensions  du UserForm avec getwindowRect
    #If VBA7 then
        Dim hWnd As LongPtr
    #Else
        Dim hWnd As Long
    #End If
    hWnd = FindWindow(vbNullString, uF.Caption)
    GetWindowRect hWnd, r
    LARGEUR = r.Right - r.Left - 4: HAUTEUR = r.Bottom - r.Top - 2
    ' Obtenir DC de la fenêtre(Dc =device Contexte)
    hSrcDC = GetWindowDC(hWnd) ' on chope le pointeur(address) du device contexte
    hMemDC = CreateCompatibleDC(hSrcDC) ' on crée un device contexte virtuel (en gros un clone)
    hBmp = CreateCompatibleBitmap(hSrcDC, LARGEUR, HAUTEUR) 'on crée un bitmap avec le contexte avec les dimensions du rectangle)
    hOldBmp = SelectObject(hMemDC, hBmp)
    ' Copier l'image
    BitBlt hMemDC, -2, 0, LARGEUR, HAUTEUR, hSrcDC, 0, 0, SRCCOPY
    ' Rétablir bitmap d’origine
    SelectObject hMemDC, hOldBmp
    ' allez on fou tout ca dans le clip boarddans clipboard
    OpenClipboard 0: EmptyClipboard: SetClipboardData CF_BITMAP, hBmp: CloseClipboard
    ' Nettoyage
    DeleteDC hMemDC
    ReleaseDC hWnd, hSrcDC
End Sub

Snapshot_BITBLT_clip2
Identique à BITBLT_clip mais avec recadrage via BitBlt avant export dans le presse-papiers.
✔️ Permet d’extraire une zone précise
❌ La fenêtre doit toujours être visible

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'          Capture UserForm avec BitBlt + découpe optionnelle (Patrick Toulon – 2025)
'                 en option on a le crop pour la barre de titre et les bordures
'                           et envoie le bitmap dans le clipboard
'Option Explicit

#If VBA7 then
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, _
                              ByVal nWidth As Long, ByVal nHeight As Long, _
                              ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    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 SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
  Private Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    ' Version 32 bits (facultatIf si 64 bits uniquement)
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP As Long = &H2

' Capture d'un UserForm dans le presse-papiers avec découpe facultative
Public Sub Snapshot_BITBLT_clip2(uF As Object, _
                                      Optional CropCaption As Boolean = False)
  
    Dim r As RECT
    Dim hSrcDC As LongPtr, hMemDC As LongPtr
    Dim hBmp As LongPtr, hOldBmp As LongPtr
    Dim hWnd As LongPtr
    Dim xCrop As Double, yCrop As Double, wCrop As Long, hCrop As Long
    Dim fullW As Long, fullH As Long, captionHeight As Double
    Dim PtToPx As Double
    ' --- Récupérer le handle de la fenêtre ---
    hWnd = FindWindow(vbNullString, uF.Caption)
    If hWnd = 0 then Exit Sub
    PtToPx = GetDpiForWindow(Application.hWnd) / 72
    ' --- Obtenir les dimensions de la fenêtre en pixels ---
    GetWindowRect hWnd, r
    fullW = r.Right - r.Left: fullH = r.Bottom - r.Top
  
    ' --- Zone par défaut (tout le UserForm) ---
    xCrop = 0: yCrop = 0
    wCrop = fullW: hCrop = fullH
  
    ' --- Supprimer la barre de titre si demandé ---
    If CropCaption then
        'Suppression de la barre de titre
        captionHeight = ((uF.height - uF.InsideHeight) + ((uF.width - uF.InsideWidth) * 2))
        yCrop = captionHeight / PtToPx
        'Suppression et report de  compensation pour le bottom
        hCrop = fullH - (captionHeight - (((uF.width - uF.InsideWidth)) / PtToPx) / 2) + 4
      
        'Suppression de la bordure gauche
        xCrop = (((uF.width - uF.InsideWidth) / PtToPx) / 2)
        'Suppression et report de  compensation pour le right
        wCrop = fullW - ((((uF.width - uF.InsideWidth) / 2) / PtToPx)) - 2
    End If
  
    ' --- Création du contexte mémoire ---
    hSrcDC = GetWindowDC(hWnd)
    hMemDC = CreateCompatibleDC(hSrcDC)
    hBmp = CreateCompatibleBitmap(hSrcDC, wCrop, hCrop)
    hOldBmp = SelectObject(hMemDC, hBmp)
  
    ' --- Copier uniquement la zone désirée ---
    BitBlt hMemDC, 0, 0, wCrop, hCrop, hSrcDC, xCrop, yCrop, SRCCOPY
  
    ' --- Rétablir le contexte d’origine ---
    SelectObject hMemDC, hOldBmp
  
    ' --- Envoyer dans le presse-papiers ---
    OpenClipboard 0
    EmptyClipboard
    SetClipboardData CF_BITMAP, hBmp
    CloseClipboard
  
    ' --- Nettoyage ---
    DeleteDC hMemDC
    ReleaseDC hWnd, hSrcDC
End Sub

Snapshot_BITBLT_ToFile1
Capture par BitBlt, puis enregistrement dans un fichier image via GDI+ (BMP, JPG, PNG, GIF).
✔️ Rendu fidèle avec effets visuels
❌ GDI+ requis

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                                       FONCTION  DE CAPTURE USERFORM
'auteur: patricktoulon
'dans cette version on utilise BitBlt et on Utilisera GDI+ pour enregistrer l'image  dans un fichier
'format de sortie possible (GIIIf ,JPG , PNG ,BMP

Option Explicit

#If VBA7 then
    ' Declarations API  USER/GDI/GDI+ pour VBA7
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
  
    ' GDI+
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As Any, ByVal Outputbuf As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr)
    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, ByRef clsidEncoder As Byte, 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 str As LongPtr, ByRef id As Byte) As Long

#Else
 ' Declarations API USER/GDI/GDI+ pour VBA6
    Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  
    ' GDI+
    Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef inputbuf As Any, ByVal Outputbuf As Long) As Long
    Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, ByRef BITMAP As Long) As Long
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As Long, ByRef clsidEncoder As Byte, ByVal encoderParams As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByRef id As Byte) As Long


#End If

Private Type RECT
    Left As Long: Top As Long: Right As Long: Bottom As Long
End Type

Private Const SRCCOPY As Long = &HCC0020

' -------- SNAPSHOT vers fichier, avec paramètre qualité (JPEG uniquement) --------
Public Sub Snapshot_BITBLT_ToFile(uF As Object, Optional fichier As String = "", Optional QualiteJPG As Long = 100)
    Dim r As RECT, hSrcDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr, hOldBmp As LongPtr, LARGEUR As Long, HAUTEUR As Long
    Dim GBitmap As LongPtr, gdiplusToken As LongPtr, gdipStartupInput(0 To 3) As Long
    Dim encoder(0 To 15) As Byte, encoderParams(0 To 3) As LongPtr, encParamBuffer(1 To 5) As Long
    Dim formatGUID As String, ext As String
   
    #If VBA7 then
        Dim hWnd As LongPtr
    #Else
        Dim hWnd As Long
    #End If
 
    If fichier = "" then fichier = Environ$("temp") & "\capture_uf.png"
    ext = LCase(Mid(fichier, InStrRev(fichier, ".")))
  
    Select Case ext
        Case ".png": formatGUID = "{557CF406-1A04-11D3-9A73-0000F81EF32E}" ' PNG
        Case ".gif": formatGUID = "{557CF402-1A04-11D3-9A73-0000F81EF32E}" ' GIF
        Case ".bmp": formatGUID = "{557CF400-1A04-11D3-9A73-0000F81EF32E}" ' BMP
        Case ".jpg", ".jpeg": formatGUID = "{557CF401-1A04-11D3-9A73-0000F81EF32E}" ' JPEG
        Case Else: MsgBox "Extension non supportée.": Exit Sub
    End Select
  
    ' Handle UserForm
    hWnd = FindWindow(vbNullString, uF.Caption)
    If hWnd = 0 then MsgBox "UserForm non trouvé.": Exit Sub
  
    GetWindowRect hWnd, r
    LARGEUR = r.Right - r.Left
    HAUTEUR = r.Bottom - r.Top
  
    ' Capture BitBlt
    hSrcDC = GetWindowDC(hWnd)
    hMemDC = CreateCompatibleDC(hSrcDC)
    hBmp = CreateCompatibleBitmap(hSrcDC, LARGEUR, HAUTEUR)
    hOldBmp = SelectObject(hMemDC, hBmp)
    BitBlt hMemDC, 0, 0, LARGEUR, HAUTEUR, hSrcDC, 0, 0, SRCCOPY
    SelectObject hMemDC, hOldBmp
  
    ' Init GDI+
    gdipStartupInput(0) = 1
    GdiplusStartup gdiplusToken, gdipStartupInput(0), 0
  
    If GdipCreateBitmapFromHBITMAP(hBmp, 0, GBitmap) = 0 then
        CLSIDFromString StrPtr(formatGUID), encoder(0)
      
        If ext = ".jpg" Or ext = ".jpeg" then
            ' EncoderParameter : qualité JPG
            encParamBuffer(1) = 1                                  ' Count
            encParamBuffer(2) = &H1D5BE4E7                         ' EncoderQuality GUID (Data)
            encParamBuffer(3) = 4                                  ' Type =Long
            encParamBuffer(4) = 1                                  ' Number of values
            encParamBuffer(5) = QualiteJPG                         ' Quality value
            encoderParams(0) = VarPtr(encParamBuffer(1))          ' Pointer vers structure EncoderParameters
            GdipSaveImageToFile GBitmap, StrPtr(fichier), encoder(0), encoderParams(0)
        Else
            GdipSaveImageToFile GBitmap, StrPtr(fichier), encoder(0), 0
        End If
      
        GdipDisposeImage GBitmap
    End If
  
    GdiplusShutdown gdiplusToken
  
    ' Nettoyage
    DeleteObject hBmp
    DeleteDC hMemDC
    ReleaseDC hWnd, hSrcDC
End Sub

Snapshot_BITBLT_FILE2
Capture BitBlt puis enregistrement binaire avec compression via WIA.
✔️ Fichier très léger
✔️ Pas besoin de GDI+
❌ WIA doit être dispo

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                                       FONCTION  DE Crop et zomm INTRA HBITMAP
'auteur: patricktoulon
'dans cette version on utilise BitBlt et on Utilisera Open For  EN BINARY POUR ECRIRE LE FICHIER EN BMP
'On converti avec WIA ensuite pour  le jpg
Option Explicit

#If VBA7 then
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal hdc As LongPtr, ByVal hBitmap As LongPtr, ByVal uStartScan As Long, ByVal cScanLines As Long, lpvBits As Any, lpbi As BITMAPINFO, ByVal uUsage As Long) As Long
#Else
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, lpvBits As Any, lpbi As BITMAPINFO, ByVal uUsage As Long) As Long
    ' ... version 32bit si besoin ...
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As Long
End Type

Private Const SRCCOPY As Long = &HCC0020
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0

Public Sub Snapshot_BITBLT_FILE2(uF As Object, ByVal jpgPath As String)
    Dim r As RECT, LARGEUR As Long, HAUTEUR As Long, hSrcDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr, hOldBmp As LongPtr
    Dim bmpBytes() As Byte, fNum As Integer, bytesPerRow As Long, bmpSize As Long, BI As BITMAPINFO, bf As BITMAPFILEHEADER
  
    #If VBA7 then
        Dim hWnd As LongPtr
    #Else
        Dim hWnd As Long
    #End If
  
    ' Trouver hWnd du UserForm
    hWnd = FindWindow(vbNullString, uF.Caption)
    If hWnd = 0 then MsgBox "UserForm non trouvé": Exit Sub
  
    ' Récup dimensions
    GetWindowRect hWnd, r
    LARGEUR = r.Right - r.Left
    HAUTEUR = r.Bottom - r.Top
  
    ' Capture dans DC
    hSrcDC = GetWindowDC(hWnd)
    hMemDC = CreateCompatibleDC(hSrcDC)
    hBmp = CreateCompatibleBitmap(hSrcDC, LARGEUR, HAUTEUR)
    hOldBmp = SelectObject(hMemDC, hBmp)
    BitBlt hMemDC, 0, 0, LARGEUR, HAUTEUR, hSrcDC, 0, 0, SRCCOPY
    SelectObject hMemDC, hOldBmp
  
    ' Préparer BITMAPINFO
    With BI.bmiHeader
        .biSize = Len(BI.bmiHeader)
        .biWidth = LARGEUR
        .biHeight = HAUTEUR
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
    End With
  
    ' Calcule taille ligne (alignée sur 4 octets)
    bytesPerRow = ((LARGEUR * 3 + 3) \ 4) * 4
    bmpSize = bytesPerRow * HAUTEUR
    ReDim bmpBytes(0 To bmpSize - 1)
  
    ' Récup pixels
    GetDIBits hMemDC, hBmp, 0, HAUTEUR, bmpBytes(0), BI, DIB_RGB_COLORS
  
    ' Créer BITMAPFILEHEADER
    With bf
        .bfType = &H4D42 ' "BM"
        .bfSize = 14 + Len(BI.bmiHeader) + bmpSize
        .bfOffBits = 14 + Len(BI.bmiHeader)
    End With
  
    ' Sauver fichier BMP
    fNum = FreeFile
    Open Replace(jpgPath, ".jpg", ".bmp") For Binary As #fNum
    Put #fNum, , bf
    Put #fNum, , BI.bmiHeader
    Put #fNum, , bmpBytes
    Close #fNum
  
    '----- Conversion BMP -> JPG avec WIA -----
    If Dir(jpgPath) <> "" then Kill jpgPath
    Dim img As Object, ip As Object
    On Error Goto CleanUp
    Set img = CreateObject("WIA.ImageFile")
    img.LoadFile Replace(jpgPath, ".jpg", ".bmp")
    Set ip = CreateObject("WIA.ImageProcess")
    ip.Filters.Add ip.FilterInfos("Convert").FilterID
    ip.Filters(1).Properties("FormatID") = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}" ' Format JPG
    ip.Filters(1).Properties("Quality") = 100 ' qualité 0-100
    Set img = ip.Apply(img)
    img.SaveFile jpgPath
    Kill Replace(jpgPath, ".jpg", ".bmp") ' Supprimer BMP temporaire
    Exit Sub
  
CleanUp:
    MsgBox "Erreur lors de la conversion en JPG : " & Err.Description
End Sub

SnapShot_PW_FormToCLIP
Capture d’une fenêtre entière (même hors écran) via PrintWindow, puis traitement par CropAndZoomClipboardBitmap.
✔️ Fonctionne même fenêtre minimisée ou hors écran
❌ Ne gère pas les effets DWM (coins arrondis, flous, etc.)

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                                       FONCTION  DE CAPTURE USERFORM
'auteur: patricktoulon
'dans cette version on utilise PrintWindow et on met le bitma dans le clipboard
'Attention ici avec pPrintWindow on recupere les bits du hdc
'le style de la fenêtre pturé estle style du shell classic
'PrintWindow a un avantage c'est qu'il permet de capturer le userform n'importe ou même entre deux ecrans
Option Explicit
Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Declare PtrSafe Function FindWindowA Lib "user32" (ByVal cls As String, ByVal cap As String) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, Rc As RECT) As Long
Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr, ByVal flags As Long) As Long
Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type


Private Type BITMAPINFO
    biSize As Long: biWidth As Long: biHeight As Long: biPlanes As Integer
    biBitCount As Integer: biCompression As Long: biSizeImage As Long
    biXPelsPerMeter As Long: biYPelsPerMeter As Long: biRUsed As Long: biRImportant As Long
End Type
Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP = &H2

Sub SnapShot_PW_FormToCLIP(Optional ByVal Usf As Object = Nothing, Optional CropCaption As Boolean = False)
    Dim lngLargeur As Long, lngHauteur As Long, bmiBitmapInfo As BITMAPINFO
    Dim lngHdc As LongPtr, lngHBmp As LongPtr, oldObj As LongPtr, Wind As LongPtr, r As RECT
    Dim bt As Double
    If Usf Is Nothing then
        Wind = Application.hWnd
    Else
        Wind = FindWindowA(vbNullString, Usf.Caption)
    End If
    If Wind = 0 then Exit Sub
    GetWindowRect Wind, r
  
    lngLargeur = r.Right - r.Left '2
    lngHauteur = r.Bottom - r.Top
    With bmiBitmapInfo
        .biBitCount = 32: .biCompression = 0&: .biPlanes = 1
        .biSize = Len(bmiBitmapInfo): .biHeight = lngHauteur: .biWidth = lngLargeur
    End With
    lngHdc = CreateCompatibleDC(0)
    lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, 0&, ByVal 0&, ByVal 0&, ByVal 0&)
    oldObj = SelectObject(lngHdc, lngHBmp)
    PrintWindow Wind, lngHdc, 0
    ' ? Copier le bitmap dans le presse-papiers (au lieu de sauvegarder)
    OpenClipboard 0
    EmptyClipboard
    SetClipboardData CF_BITMAP, lngHBmp
    CloseClipboard
    ' Attention : on NE détruit PAS le bitmap s’il est dans le presse-papiers !
    SelectObject lngHdc, oldObj
    DeleteObject lngHdc
  
    If CropCaption then
        Dim PtToPx As Double, Croptp As Double, cropSide As Double
        PtToPx = GetDpiForWindow(Application.hWnd) / 72
        Croptp = (((Usf.width - Usf.InsideWidth) * 2) + (Usf.height - Usf.InsideHeight)) / PtToPx
        cropSide = ((Usf.width - Usf.InsideWidth) / 2) / PtToPx
        CropAndZoomClipboardBitmap cropSide, Croptp, lngLargeur - (cropSide * 2), lngHauteur - Croptp - cropSide
    End If
End Sub

SnapShot_PW_FormToFile
Capture via PrintWindow avec export fichier (BMP, JPG, PNG, etc.) via GDI+.
✔️ Capture fiable hors écran
❌ Image visuellement plate (pas d’effets DWM)

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                                       FONCTION  DE CAPTURE USERFORM
'auteur: patricktoulon
'dans cette version on utilise PrintWindow et on met le bitma dans le clipboard
'Attention ici avec pPrintWindow on recupere les bits du hdc
'le style de la fenêtre cappturée est le style du shell classic
'//////////////////////////////////////////////////////
'

'Discussion:
'https://www.developpez.net/forums/d2169702/logiciels/microsoft-office/excel/macros-vba-excel/capture-d-ecran-usf-64-bit/#post12045083

'dans cette version on utilise PrintWindow et on utilise gdi+ pour sauver l'image en fichier
'Attention ici avec PrintWindow on recupere les bits du hdc
'le style de la fenêtre capturé est le style du shell classic
'PrintWindow a un avantage c'est qu'il permet de capturer le userform n'importe ou même entre deux ecrans
'creation de l'image avec gdi+ avec le CLISD correspondant au format voulu(png,jpg,gif,bmp)
'Attention le gIf rEnd mal a ne pas utiliser

Option Explicit

Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal cls As String, ByVal cap As String) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, Rc As RECT) As Long
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr, ByVal flags As Long) As Long
Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
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 SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
' GDI +
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hpal As LongPtr, GBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal GBitmap As LongPtr, ByVal filename As LongPtr, ByVal pclsidEncoder As LongPtr, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal GBitmap As LongPtr) As LongPtr
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, GInput As GdiplusStartupInput, ByVal GOutput As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, ByVal pGuid As LongPtr) As Long

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

Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type

Private Type BITMAPINFO
    biSize As Long: biWidth As Long: biHeight As Long: biPlanes As Integer
    biBitCount As Integer: biCompression As Long: biSizeImage As Long
    biXPelsPerMeter As Long: biYPelsPerMeter As Long: biRUsed As Long: biRImportant As Long
End Type

Sub SnapShot_PW_FormToFile(Optional ByVal Usf As Object = Nothing, Optional ByVal aFilename As String = "")
    Static gdiplusToken As LongPtr, lngLargeur As Long, lngHauteur As Long, lngHdc As LongPtr, lngHBmp As LongPtr, oldObj As LongPtr
    Dim Wind As LongPtr, r As RECT, encoder(0 To 15) As Byte, GBitmap As LongPtr, Format_GUID As String
    Dim profondeur_color As Long, bmiBitmapInfo As BITMAPINFO, StartupInput As GdiplusStartupInput
  
    If aFilename <> "" then
        Select Case LCase(Mid(aFilename, InStrRev(aFilename, ".")))
            Case ".png": Format_GUID = "{557CF406-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
            Case ".gif": Format_GUID = "{557CF402-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 8
            Case ".bmp": Format_GUID = "{557CF400-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
            Case ".jpg", ".jpeg": Format_GUID = "{557CF401-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
        End Select
    End If
    If Usf Is Nothing then
        Wind = Application.hWnd
        'GetDesktopWindow() 'printwindow deraille avec les fenêtre qui utilise l'accélération matérielle (directx openGL etc...)
    Else
        Wind = FindWindowA(vbNullString, Usf.Caption)
    End If
  
    If Wind = 0 then Exit Sub
    GetWindowRect Wind, r
    lngLargeur = r.Right - r.Left
    lngHauteur = r.Bottom - r.Top
  
    'With bmiBitmapInfo
    '.biBitCount = profondeur_color: .biCompression = 0&: .biPlanes = 1
    '.biSize = Len(bmiBitmapInfo): .biHeight = lngHauteur: .biWidth = lngLargeur
    '.biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
    'End With
    With bmiBitmapInfo
        .biBitCount = 32: .biCompression = 0&: .biPlanes = 1
        .biSize = Len(bmiBitmapInfo): .biHeight = lngHauteur: .biWidth = lngLargeur
    End With
    lngHdc = CreateCompatibleDC(0)
    lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, 0&, ByVal 0&, ByVal 0&, ByVal 0&)
    oldObj = SelectObject(lngHdc, lngHBmp)
  
    PrintWindow Wind, lngHdc, 0
  
    If gdiplusToken = 0 then
        StartupInput.GdiplusVersion = 1
        GdiplusStartup gdiplusToken, StartupInput, 0
    End If
    If GdipCreateBitmapFromHBITMAP(lngHBmp, 0, GBitmap) = 0 then
        CLSIDFromString StrPtr(Format_GUID), VarPtr(encoder(0))
        GdipSaveImageToFile GBitmap, StrPtr(aFilename), VarPtr(encoder(0)), 0
        GdipDisposeImage GBitmap
    End If
  
    oldObj = SelectObject(lngHdc, oldObj)
    DeleteObject lngHBmp
    DeleteObject lngHdc
End Sub

CropAndZoomClipboardBitmap
Récupère l’image dans le presse-papiers, effectue un recadrage et/ou zoom par StretchBlt uniquement.
✔️ Simple et rapide
❌ Qualité dépendante du facteur de zoom

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                  FONCTION  pour croper l'image  bitmap directement dans le clipbord
'                                           Ou la zommer
'auteur: patricktoulon
'====================================================================================================
'    Découpe et/ou Zoom sur le Bitmap actuellement dans le ClipBoard
'    paramètre 1:  x     : Crop du left
'    paramètre 2:  y     : crop du top
'    paramètre 3:  w      : largeur que l'on garde  a partir de x
'    paramètre 4:  h      : Hauteur que l'on garde a partir de y (si 0 => pleine image)
'    paramètre 4:  xscale : facteur de zoom (1 = taille originale, 2 = 200%, Etc.)
'====================================================================================================
Option Explicit

#If VBA7 then
    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 IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, ByRef lpObject As Any) As Long
    Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, _
                                                             ByVal nDestWidth As Long, ByVal nDestHeight As Long, _
                                                             ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, _
                                                             ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
                                                             ByVal dwRop As Long) As Long
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
    Private Declare Function StretchBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
                                                     ByVal nDestWidth As Long, ByVal nDestHeight As Long, _
                                                     ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
                                                     ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
                                                     ByVal dwRop As Long) As Long
#End If

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As LongPtr
End Type

Private Const CF_BITMAP As Long = 2
Private Const SRCCOPY As Long = &HCC0020

Public Sub CropAndZoomClipboardBitmap(Optional ByVal x As Long = 0, _
                                      Optional ByVal y As Long = 0, _
                                      Optional ByVal w As Long = 0, _
                                      Optional ByVal h As Long = 0, _
                                      Optional ByVal xscale As Double = 1)

    Dim hBmpSrc As LongPtr, hBmpNew As LongPtr, hSrcDC As LongPtr, hDstDC As LongPtr, hScreenDC As LongPtr
    Dim oldObj As LongPtr, newOldObj As LongPtr, bmp As BITMAP, finalW As Long, finalH As Long

    If OpenClipboard(0) = 0 then Exit Sub
    If IsClipboardFormatAvailable(CF_BITMAP) = 0 then CloseClipboard: Exit Sub

    hBmpSrc = GetClipboardData(CF_BITMAP)
    If hBmpSrc = 0 then CloseClipboard: Exit Sub
    CloseClipboard

    ' Récupérer les dimensions du bitmap source
    GetObjectAPI hBmpSrc, Len(bmp), bmp
    If w = 0 then w = bmp.bmWidth
    If h = 0 then h = bmp.bmHeight

    finalW = Clng(w * xscale)
    finalH = Clng(h * xscale)

    ' Créer un nouveau bitmap mis à l’échelle
    hScreenDC = GetDC(0)
    hDstDC = CreateCompatibleDC(hScreenDC)
    hSrcDC = CreateCompatibleDC(hScreenDC)
    hBmpNew = CreateCompatibleBitmap(hScreenDC, finalW, finalH)
    oldObj = SelectObject(hSrcDC, hBmpSrc)
    newOldObj = SelectObject(hDstDC, hBmpNew)

    ' Copier/découper/redimensionner
    StretchBlt hDstDC, 0, 0, finalW, finalH, hSrcDC, x, y, w, h, SRCCOPY

    ' Remettre les objets initiaux
    SelectObject hDstDC, newOldObj
    SelectObject hSrcDC, oldObj

    ' Mettre le résultat dans le presse-papiers
    If OpenClipboard(0) then
        EmptyClipboard
        SetClipboardData CF_BITMAP, hBmpNew
        CloseClipboard
    End If

    ' Nettoyage
    DeleteDC hSrcDC
    DeleteDC hDstDC
    ReleaseDC 0, hScreenDC
    ' hBmpNew non détruit : transféré au clipboard
End Sub

🧮 Tableau comparatif

Fonction	API	Destination	Visibilité requise	Effets DWM	Zoom/Crop	Compression	Notes
BITBLT_clip	BitBlt	Clipboard	✅	✅	❌	❌	Simple, rapide
BITBLT_clip2	BitBlt	Clipboard	✅	✅	✅	❌	Avec recadrage
BITBLT_ToFile1	BitBlt + GDI+	Fichier	✅	✅	❌	❌	Multi-format
BITBLT_FILE2	BitBlt + WIA	Fichier	✅	✅	❌	✅	Compression légère
PW_FormToCLIP	PrintWindow	Clipboard	❌	❌	✅	❌	Fonctionne même minimisée
PW_FormToFile	PrintWindow + GDI+	Fichier	❌	❌	✅	❌	Pour archivage
CropAndZoomClipboard	StretchBlt	Clipboard	—	✅ (si source)	✅	❌	Post-traitement rapide

Conclusion

nous voyons que les deux solutions ont leur avantages et inconvenients mais la velocité est là
dans certains de ces exemples ,on tripote un peu gdi et gdi+ ,un grand atout pour le graphique en vba
je l'ai voulu le plus hexaustif possible en terme de comparaison

Patrick

Auteur: patricktoulon

Version: 1.0

capture ecran ou portion d'ecran avec les methode BitBlt et printwindow 1.0

Évaluations

Plus de ressources de patricktoulon

Partager cette ressource

capture ecran ou portion d'ecran avec les methode BitBlt et printwindow 1.0

Évaluations

Plus de ressources de patricktoulon

Partager cette ressource

Privacy & Transparency

Privacy & Transparency