Implémentation d'un IDataObject complet

[ZapMan]

Le fichier étant trop imposant pour être inclus dans un post, voici l'adresse de téléchargement :
https://www.editions-humanis.com/downlo ... brary.zip

Un grand merci à Nico du forum PureBasic. Autant que je sache, il a été le premier à essayer d'implémenter un IDataObject en PureBasic et il a réalisé une partie importante du travail présenté ici. Il y a dix ans, en partant de son travail, j'ai commencé à avancer sur ce projet pour les besoins des fonctionnalités de glisser-déposer dans l'un de mes programmes. Cette année, j'ai finalement décidé de pousser l'implémentation aussi loin que possible, afin d'obtenir un IDataObject entièrement fonctionnel pour tout usage futur.

Cette implémentation permet à l'IDataObject de supporter les méthodes 'SetData', 'GetData' et 'GetDataHere' pour la plupart des formats possibles. L'objet répond également aux requêtes pour EnumFormatEtc, EnumAdvise, QueryGetData, QueryInterface, AddRef, DAdvise, DUnAdvise et Release. Cet IDataObject est conçu pour être aussi générique que possible, mais, bien sûr, vous pouvez adapter son code à vos besoins spécifiques.

L'interface 'IDataObject' de Windows permet de manipuler et transférer des données entre différentes applications ou processus, par exemple via le presse-papiers ou le glisser-déposer. Elle permet d'accéder aux données sous plusieurs formats, regroupées dans un objet que d'autres applications peuvent utiliser. Les méthodes principales sont GetData (pour récupérer des données), SetData (pour définir des données), et EnumFormatEtc (pour lister les formats de données disponibles). IDataObject est souvent utilisé dans des environnements OLE pour lier ou intégrer des objets dans des documents ou des applications.

Dans Windows, un objet représente une entité qui contient des données et des fonctions. Un objet a des interfaces, qui sont des façons d'accéder à ses fonctionnalités, comme lire des fichiers ou gérer des flux de données. Les objets dans Windows utilisent souvent COM (Component Object Model), où une interface de base comme IUnknown permet de gérer les références et la communication entre objets. Ce modèle aide les composants logiciels à bien fonctionner ensemble en respectant certaines règles d'interface.

La programmation orientée objet (POO) organise le code en objets qui contiennent à la fois des données (appelées propriétés) et des fonctions (appelées méthodes) pour les manipuler. Chaque objet est comme une petite unité autonome, représentant une chose du monde réel, comme une fenêtre ou un fichier. Cela permet de structurer les programmes de manière plus claire et réutilisable. Les objets peuvent interagir entre eux, ce qui rend le code plus flexible et modulaire.

En comparaison, la programmation traditionnelle, souvent appelée 'programmation procédurale', suit un plan linéaire où les instructions sont exécutées les unes après les autres. Les données et les fonctions sont séparées, et le programme est généralement organisé en grandes séquences de code. Bien que plus simple au départ, cette approche peut présenter des limites pour gérer des projets importants comportant beaucoup d'interactions entre différentes parties du programme. Ces limites peuvent être parfaitement gérées par une structure solide et une segmentation du code en procédures plus ou moins autonomes. Mais certains préfèrent une approche plus radicale où chaque fonction est organisée en tant qu'objet indépendant avec une liste stricte de "méthodes" qui permettent d'interagir avec lui. C'est le choix qui a été fait pour de nombreux sous-ensembles de fonctions de Windows, et il est désormais inévitable, lorsque l'on veut interagir avec Windows à travers ses API, de comprendre le principe de cette forme de programmation.

Pour tout ce qui concerne la manipulation des données (lecture et écriture de fichiers, copier-coller, flux audio et vidéo, Drag'n Drop, et affichage à l'écran), il est presque indispensable, si l'on veut dépasser certaines limites des fonctions d'origine que propose PureBasic, de savoir créer et gérer un IDataObject. Malheureusement, si Windows impose souvent l'utilisation de ce type d'objet, aucune API ne propose un moyen simple de le créer et il suffit de parcourir les forums de tous les langages de programmation pour constater que cette question y revient très souvent : "comment créer un IDataObject ?"

C'est pour y répondre que cette librairie a été conçue.

[ZapMan]

Et voici quelques fonctions pratiques pour manipuler les IDataObject, ainsi qu'un test final. Une copie de ce fichier figure dans le zip proposé plus haut en téléchargement :

Code : Tout sélectionner

; **********************************************************************
;
;    Set of procedures for manipulating, examining, or filling
;                           IDataObjects
;
;    A test for some functions figures at the end of this file
;
;                      For Windows only - PB 6.11
;                          Sept 2024 - Zapman
;
;
; **********************************************************************
;
;-                          SET DATA HELPERS
;
; **********************************************************************
;
; SetIDataObjectData_Helper(), just like AddStreamToDataObject_Helper(),
; are very useful (but not essential) procedures for filling an IDataObject
; with Data.
; The procedures FilesListToHandle() and GetDIBHandleFromImage()
; are required for the operation of SetIDataObjectData_Helper()
;
XIncludeFile("IDataObject.pb")
;XIncludeFile("TOM_Functions.pb")
;
Procedure.s HandleToFilesList(handle)
  ; Extract FilesList from a DROPFILE Structure
  ;
  Protected *pDrop.DROPFILES, *buffer, SOC, pos, nbzero
  Protected StringSize, *buffer2, ct, MyString$
  ;
  *pDrop.DROPFILES = GlobalLock_(handle)
  *buffer = *pDrop + *pDrop\pFiles ; data is stored at this adress
  If *pDrop\fWide =#True ; if FilesList is stored in unicode mode, each character has 2 bytes size
    SOC = 2
  Else
    SOC = 1
  EndIf
  pos = -SOC
  nbzero = 0
  Repeat ; look for a double zero at the end of the FilesList
    pos + SOC
    If PeekB(*buffer+pos)=0
      nbzero + 1
    Else
      nbzero = 0
    EndIf
  Until nbzero = 2 Or pos>1000 ; If we don't find a double zero, we stop to explore the memory after 1000 character
  If nbzero = 2 ; OK, we now have the lenght of the FilesList
    StringSize = pos
    *buffer2 = AllocateMemory(StringSize)
    CopyMemory(*buffer,*buffer2,StringSize) ; duplicate the buffer to leave the original buffer as it is
    ct = 0
    Repeat
      If PeekB(*buffer2+ct)=0
        PokeB(*buffer2+ct,10) ; replace zero by chr(10) in all the FilesList
      EndIf
      ct + SOC
    Until ct = (StringSize-SOC)
    If *pDrop\fWide =#True
      MyString$ = PeekS(*buffer2,#PB_Any,#PB_Unicode)
    Else
      MyString$ = PeekS(*buffer2,#PB_Any,#PB_Ascii)
    EndIf
    FreeMemory(*buffer2)
  EndIf
  GlobalUnlock_(handle)
  ProcedureReturn MyString$
EndProcedure
;
Procedure FilesListToHandle(MyString.s)
  ;
  ; Copy a list of files into a Global memory block inside a DROPFILE Structure.
  ; The original string must be a list of filenames separated by the chr(10) character.
  ;
  Protected StringSize, hData, *pDrop.DROPFILES, pData, ct
  ;
  If Right(MyString,1)<>Chr(10) ; If we have no chr(10) at the end of the list, we add one.
    MyString + Chr(10)
  EndIf
  ; The string included into the DROPFILES structure must be terminated by a double zero.
  MyString + Chr(10)
  ; Chr(10) will be replaced by zero, so we'll get a string terminated by a double zero.
  StringSize = (SizeOf(Character) * Len(MyString)) ; To be compatible with Unicode compilation mode
  hData = GlobalAlloc_(#GMEM_MOVEABLE,SizeOf(DROPFILES) + StringSize)
  If hData
    *pDrop.DROPFILES = GlobalLock_(hData)
    If *pDrop
      *pDrop\pFiles = SizeOf(DROPFILES) ; Size of the DROPFILES structure
      pData = *pDrop + *pDrop\pFiles    ; Data will be paste at the end of the DROPFILES structure
      CopyMemory(@MyString,pData, StringSize)
      For ct = pData To (pData+StringSize) Step SizeOf(Character) ; Replace all chr(10) by zero.
        If PeekB(ct)=10 : PokeB(ct,0) : EndIf
      Next
      If #PB_Compiler_Unicode 
        ; If we're compiling for Unicode, set the Unicode flag in the struct to
        ; indicate it contains Unicode strings.
        *pDrop\fWide =#True;
      Else
        *pDrop\fWide =#False
      EndIf
    Else
      GlobalUnlock_(hData)
      GlobalFree_(hData)
      ProcedureReturn 0
    EndIf
    GlobalUnlock_(hData)
  EndIf
  ProcedureReturn hData
EndProcedure
;
Procedure GetDIBHandleFromImage(HBitmap)
  ;
  ; This procedure works with a PureBasic image ID
  ; or with a handle to the image.
  ; It encapsulates the Bitmap data into a DIB, which is
  ; a format handled by many Windows functions, 
  ; especially the GDI API functions.
  ;
  If IsImage(HBitmap)
    HBitmap = ImageID(HBitmap)
  EndIf
  ;
  Protected TemporaryDC.L, TemporaryBitmap.BITMAP, TemporaryBitmapInfo.BITMAPINFO
  Protected hDib, *Buffer
  Protected BitmapSize
  
  ; Create a temporary device context (DC):
  TemporaryDC = CreateDC_("DISPLAY", #Null, #Null, #Null)
  
  ; Retrieve information about the bitmap (HBitmap):
  GetObject_(HBitmap, SizeOf(BITMAP), @TemporaryBitmap)
  
  ; Initialize the BITMAPINFOHEADER information:
  TemporaryBitmapInfo\bmiHeader\biSize        = SizeOf(BITMAPINFOHEADER)
  TemporaryBitmapInfo\bmiHeader\biWidth       = TemporaryBitmap\bmWidth
  TemporaryBitmapInfo\bmiHeader\biHeight      = TemporaryBitmap\bmHeight
  TemporaryBitmapInfo\bmiHeader\biPlanes      = 1
  TemporaryBitmapInfo\bmiHeader\biBitCount    = 32                         ; 32 bits / pixel
  TemporaryBitmapInfo\bmiHeader\biCompression = #BI_RGB
  
  ; Calculate the required size for the DIB:
  BitmapSize = TemporaryBitmap\bmWidth * TemporaryBitmap\bmHeight * (TemporaryBitmapInfo\bmiHeader\biBitCount / 8)
  
  ; Allocate memory for the DIB (Device Independent Bitmap)
  hDib = GlobalAlloc_(#GMEM_MOVEABLE, BitmapSize + SizeOf(BITMAPINFOHEADER))
  
  If hDib
    *Buffer = GlobalLock_(hDib)
    If *Buffer
      ; Copy the BITMAPINFOHEADER header into memory
      CopyMemory(@TemporaryBitmapInfo\bmiHeader, *Buffer, SizeOf(BITMAPINFOHEADER))
      
      ; Copy the bitmap bits into memory after the header
      GetDIBits_(TemporaryDC, HBITMAP, 0, TemporaryBitmap\bmHeight, *Buffer + SizeOf(BITMAPINFOHEADER), TemporaryBitmapInfo, #DIB_RGB_COLORS)
      
      GlobalUnlock_(hDib)
    Else
      ; Lock failed, free the memory
      GlobalFree_(hDib)
      hDib = 0
    EndIf
  EndIf
  
  ; Free and delete the device context (DC)
  DeleteDC_(TemporaryDC)
  
  ; Return the handle to the DIB
  ProcedureReturn hDib
  ;
EndProcedure
;
Procedure SetIDataObjectData_Helper(*MyDataObject.IDataObject, Format, *Buffer = 0, Image = 0, StringData$ = "", FileName$ = "")
  ;
  ; This procedure is a 'Helper' that can assist you in filling an IDataObject with
  ; data without having to manipulate the content of 'FormatEtc' and 'StgMedium' structures.
  ;
  ; It adds data to an IDataObject after formatting them so that they are accepted by it.
  ;
  ; Example of usage: SetIDataObjectDataHelper(MyDataObject, #CF_TEXT, 0, 0, "Test")
  ;    -> Adds the string "Test" as Ascii data to the IDataObject.
  ;
  ; The "Format" parameter must contain one of the constants defined by Windows in
  ; the 'Standard Clipboard Formats' enumeration, and the corresponding data must be
  ; provided through one of the parameters offered for this purpose.
  ; Use *Buffer to provide raw data, Image to provide a PureBasic image ID
  ; or a bitmap handle, StringData$ to provide text, and FileName$ to provide a filename
  ; and create #CF_Drop type data.
  ;
  ; This helper is designed to handle the most common cases of adding data and may not
  ; cover all the use cases and data types that an IDataObject can carry. You are free to
  ; modify and improve it if you want to make it more powerful.
  ;
  Protected MyFormatEtc.FormatEtc, MyStgMed.StgMedium
  Protected hBitmap, hDib, hGlobal, *DataBuffer, *DataBufferTemp
  Protected FormatName$, tx$, BitStream, SC
  ;
  If *MyDataObject = 0
    MessageRequester("Oops!", "IData parameter is null.")
    ProcedureReturn #False
  EndIf
  If FileName$ And Format <> #CF_HDROP
    MessageRequester("Oops!", "Format must be CF_HDROP when a filename is set.")
    ProcedureReturn #False
  EndIf
  ; ________________________________________________
  ;             Set Values for FORMATETC
  ;
  Select Format
    Case #CF_BITMAP
      MyFormatEtc\tymed = #TYMED_GDI
    Case #CF_TEXT, #CF_OEMTEXT, #CF_DIB, #CF_UNICODETEXT, #CF_HDROP
      MyFormatEtc\tymed = #TYMED_HGLOBAL
    Default
      FormatName$ = GetFormatName(Format)
      If FindString(FormatName$, "RTF") Or FindString(FormatName$, "Rich Text")
        MyFormatEtc\tymed = #TYMED_HGLOBAL
      ElseIf *Buffer = 0
        tx$ = "Format " + GetFormatName(Format) + " is not yet supported by SetIDataObjectDataHelper()" +Chr(13)
        tx$ + "You must encode the data by yourself and provide it through '*Buffer' parameter."
        MessageRequester("Oops!", tx$)
        Debug "SetIDataObjectDataHelper: Unsupported format"
      EndIf
      ProcedureReturn #False
  EndSelect
  ;
  ;
  MyFormatEtc\cfFormat = Format             ; Set the format
  MyFormatEtc\ptd = #Null                   ; Target Device = Screen
  MyFormatEtc\dwAspect = #DVASPECT_CONTENT  ; Level of detail = Full content
  MyFormatEtc\lindex = -1                   ; Index = Not applicable

  ; ________________________________________________
  ;             Set Values for STGMEDIUM
  ;
  MyStgMed\pUnkForRelease = #Null        ; Use ReleaseStgMedium_() APIFunction
  MyStgMed\tymed = MyFormatEtc\tymed     ; MyStgMed and MyFormatEtc must have the same value
                                         ;   in their respective 'tymed' fields.

  ; ________________________________________________
  ;             Handle Data according to Type
  ;
  If Image
    If *Buffer Or StringData$ Or FileName$
      Debug "SetIDataObjectDataHelper error: Only one type of data must be set."
      ProcedureReturn #False
    EndIf
    If IsImage(Image)
      Image = ImageID(Image)
    EndIf
    hBitmap = CopyImage_(Image, #IMAGE_BITMAP, 0, 0, #LR_COPYRETURNORG)
    If hBitmap = 0
      Debug "SetIDataObjectDataHelper: Unable to copy image."
      ProcedureReturn #False
    EndIf
    If Format = #CF_DIB
      hDib = GetDIBHandleFromImage(hBitmap)
      MyStgMed\hGlobal = hDib
      DeleteObject_(hBitmap)
      If MyStgMed\hGlobal = 0
        Debug "SetIDataObjectDataHelper: Unable to convert image to DIB."
        ProcedureReturn #False
      EndIf
    ElseIf Format = #CF_BITMAP
      MyStgMed\hBitmap = hBitmap
    Else
      DeleteObject_(hBitmap)
      Debug "SetIDataObjectDataHelper doesn't support " + GetFormatName(Format) + "."
      ProcedureReturn #False
    EndIf

  ElseIf *Buffer
    If StringData$ Or FileName$
      Debug "SetIDataObjectDataHelper error: Only one type of data must be set."
      ProcedureReturn #False
    EndIf
    hGlobal = GlobalAlloc_(#GMEM_MOVEABLE, MemorySize(*Buffer))
    If hGlobal = 0
      Debug "SetIDataObjectDataHelper: Unable to create HGlobal."
      ProcedureReturn #False
    Else
      *DataBuffer = GlobalLock_(MyStgMed\hGlobal)
      If *DataBuffer
        CopyMemory(*Buffer, *DataBuffer, GlobalSize_(MyStgMed\hGlobal))    
        GlobalUnlock_(hGlobal)
        MyStgMed\hGlobal = hGlobal
      Else
        GlobalFree_(hGlobal)
        hGlobal = 0
        Debug "SetIDataObjectDataHelper: Unable to get a buffer from HGlobal."
        ProcedureReturn #False
      EndIf
    EndIf

  ElseIf StringData$
     If FileName$
      Debug "SetIDataObjectDataHelper error: Only one type of data must be set."
      ProcedureReturn #False
    EndIf
    FormatName$ = GetFormatName(Format)
    If Format = #CF_TEXT Or Format = #CF_OEMTEXT Or FindString(FormatName$, "RTF") Or FindString(FormatName$, "Rich Text")
      hGlobal = GlobalAlloc_(#GMEM_MOVEABLE, (Len(StringData$) + 1))
      If hGlobal = 0
        Debug "SetIDataObjectDataHelper: Unable to allocate memory for string"
        ProcedureReturn #False
      Else
        *DataBuffer = GlobalLock_(hGlobal)
        If *DataBuffer
          If Format = #CF_OEMTEXT
            *DataBufferTemp = AllocateMemory(Len(StringData$) + 1)
            PokeS(*DataBufferTemp, StringData$, -1, #PB_Ascii)
            CharToOem_(*DataBufferTemp, *DataBuffer)
            FreeMemory(*DataBufferTemp)
          Else
            PokeS(*DataBuffer, StringData$, -1, #PB_Ascii)
          EndIf
          GlobalUnlock_(hGlobal)
          MyStgMed\hGlobal = hGlobal
        Else
          GlobalFree_(hGlobal)
          hGlobal = 0
          Debug "SetIDataObjectDataHelper: Unable to get a buffer for string."
          ProcedureReturn #False
        EndIf
      EndIf
    ElseIf Format = #CF_UNICODETEXT
      ; On converti la chaîne en BitStream :
      BitStream = SysAllocString_(@StringData$)
      If BitStream = 0
        Debug "SetIDataObjectDataHelper: Unable to allocate memory for string"
        ProcedureReturn #False
      EndIf
      ; On crée un HGlobal pour la copier
      hGlobal = GlobalAlloc_(#GMEM_MOVEABLE, SysStringByteLen_(BitStream) + 2)
      If hGlobal = 0
        Debug "SetIDataObjectDataHelper: Unable to allocate memory for string"
        ProcedureReturn #False
      Else
        ; On verrouille le HGlobal pour l'utiliser
        *DataBuffer = GlobalLock_(hGlobal)
        If *DataBuffer
          ; On copie le BitStream dans le hGlobal
          CopyMemory(BitStream, *DataBuffer, SysStringByteLen_(BitStream) + 2)
          ; On libère le BitStream
          SysFreeString_(BitStream)
          ; On déverrouille le HGlobal
          GlobalUnlock_(hGlobal)
          ; On attribue le HGlobal
          MyStgMed\hGlobal = hGlobal
        Else
          GlobalFree_(hGlobal)
          hGlobal = 0
          Debug "SetIDataObjectDataHelper: Unable to get a buffer for string."
          ProcedureReturn #False
        EndIf
      EndIf
    Else
      Debug "SetIDataObjectDataHelper: Unsupported string format."
      ProcedureReturn #False
    EndIf
  ElseIf FileName$ And Format = #CF_HDROP
    If FileSize(FileName$) > 1
      hGlobal = FilesListToHandle(FileName$)
      If hGlobal
        MyStgMed\hGlobal = hGlobal
      Else
        Debug "SetIDataObjectDataHelper: Unable to compute HDROP from filename."
        ProcedureReturn #False
      EndIf
    Else
      Debug "FileSize is null."
      ProcedureReturn #False
    EndIf
  ElseIf FileName$ And OtherCondition
    If FileSize(FileName$) > 1
      BitStream = SysAllocString_(@FileName$)
      MyStgMed\lpszFileName = BitStream
      If MyStgMed\lpszFileName = 0
        Debug "SetIDataObjectDataHelper: Unable to allocate memory for string"
        ProcedureReturn #False
      EndIf
    Else
      Debug "FileSize is null."
      ProcedureReturn #False
    EndIf
  Else
    Debug "SetIDataObjectDataHelper needs data to do the job."
    ProcedureReturn #False
  EndIf
  ;
  ; _________________________________________________________________
  ;
  ;             Finally, call SetData on the IDataObject
  ;
  ; _________________________________________________________________
  ;
  SC = *MyDataObject\SetData(@MyFormatEtc, @MyStgMed, #True)
  ; The IDataObject make a copy of the given data and clean the original ones, because
  ; last parametre is set to '#True'
  ;
  If SC <> #S_OK
    Debug "SetIDataObjectDataHelper failed with error code: " + Hex(SC) + " / "+GetWinErrorMessage(SC)
    ProcedureReturn #False
  EndIf

  ProcedureReturn #True
EndProcedure
;
Procedure AddStreamToDataObject_Helper(*pDataObject.IDataObject, *pStream.IStream)
  ;
  ; Function to add a stream to an existing IDataObject
  ;
  ; The SetIDataObjectData_Helper() procedure does not allow adding streamed data
  ; to an IDataObject. This procedure is therefore designed to accomplish this task.
  ;
  Protected formatetc.FORMATETC
  Protected stgmedium.STGMEDIUM
  Protected result

  ; Préparer FORMATETC pour le stream
  formatetc\cfFormat = #CF_UNICODETEXT
  formatetc\ptd = 0
  formatetc\dwAspect = #DVASPECT_CONTENT
  formatetc\lindex = -1
  formatetc\tymed = #TYMED_ISTREAM

  ; Préparer STGMEDIUM pour stocker le flux
  stgmedium\tymed = #TYMED_ISTREAM
  stgmedium\pstm = *pStream
  stgmedium\pUnkForRelease = #Null ; Pas de gestion automatique

  ; Associer le flux au IDataObject
  result = *pDataObject\SetData(@formatetc, @stgmedium, #True)
  If result = #S_OK
    Debug "AddStreamToDataObject_Helper: Stream successfully added to IDataObject."
  Else
    Debug "AddStreamToDataObject_Helper: Failed to add stream to IDataObject. Error: " + Hex(result)
  EndIf
EndProcedure
;
; *****************************************************************************
;-                          EXAMINATION PROCEDURES :
;
; EnumFormatsFromIDataObject(), breaks down all the data
; present in the IDataObject and provides an overview.
; The procedures above are used by EnumFormatsFromIDataObject()
;
; *****************************************************************************
;
Procedure.i IsMemoryValid(*ptr)
  Protected result.i = #False
  Protected mbi.MEMORY_BASIC_INFORMATION
  
  result = VirtualQuery_(*ptr, @mbi, SizeOf(MEMORY_BASIC_INFORMATION))
  If result And result <> #ERROR_INVALID_PARAMETER
    If mbi\State = #MEM_COMMIT And (mbi\Protect & (#PAGE_NOACCESS | #PAGE_GUARD)) = 0
      result = #True
    EndIf
  Else
    result = #False
  EndIf
  
  ProcedureReturn result
EndProcedure
;
Procedure ShowBitmapPictInWindow(hWd, hBitmap)
  Protected hdcWindow = GetDC_(hWd)
  Protected rect.RECT, SRatio.f
  GetClientRect_(hWd, @rect)
  ; Calcule la largeur et la hauteur du gadget ou de la fenêtre
  Protected destWidth = rect\right - rect\left
  Protected destHeight = rect\bottom - rect\top
  If hBitmap
    ; Récupère le Bitmap
    Protected bmp.BITMAP
    GetObject_(hBitmap, SizeOf(BITMAP), @bmp)
    ;
    SRatio.f = bmp\bmWidth/bmp\bmHeight
    If SRatio < 1
      destWidth = destHeight*SRatio
    Else
      destHeight = destWidth/SRatio
    EndIf
    ;
    ; Crée un contexte de mémoire pour contenir le bitmap
    Protected hdcMem = CreateCompatibleDC_(hdcWindow)
    If hdcMem
      ; Sélectionne le bitmap dans le contexte de mémoire
      SelectObject_(hdcMem, hBitmap)
      ; Copie le bitmap redimensionné dans la fenêtre ou le gadget
      StretchBlt_(hdcWindow, 0, 0, destWidth, destHeight, hdcMem, 0, 0, bmp\bmWidth, bmp\bmHeight, #SRCCOPY)
      ; Nettoyer le contexte de mémoire
      DeleteDC_(hdcMem)
    Else
      Debug "Unable to create CompatibleDC"
    EndIf
  EndIf
EndProcedure
;
Import "gdiplus.lib"
  GdiplusStartup(*token, *input, *output)
  GdiplusShutdown(token)
  GdipCreateHBITMAPFromBitmap(Bitmap.i, *GdiPImage, *background)
  GdipLoadImageFromStream(pStream.IStream, *GdiPImage)
  GdipDisposeImage(GdiPImage.i)
EndImport
;
Procedure ShowStreamedPictInWindow(hWd, *pStream)
  Protected *pImage, hBitmap, SC
  ;
  Shared GdiplusToken ; Must be shared or global to be accepted by GdiplusStartup
  Structure GdiplusStartupInput
    GdiplusVersion.l
    DebugEventCallback.l
    SuppressBackgroundThread.l
    SuppressExternalCodecs.l
  EndStructure
  Protected GdiplusStartupInput.GdiplusStartupInput
  
  GdiplusStartupInput\GdiplusVersion = 1
  SC = GdiplusStartup(@GdiplusToken, @GdiplusStartupInput, #Null)
  If SC = #S_OK
    SC = GdipLoadImageFromStream(*pStream, @*pImage)
    If SC = #S_OK
    
      ; Convertir l'image GDI+ en HBITMAP
      SC = GdipCreateHBITMAPFromBitmap(*pImage, @hBitmap, 0)
      If SC = #S_OK
        ShowBitmapPictInWindow(hWd, hBitmap)
        DeleteObject_(hBitmap)
      Else
        Debug "Unable to create bitmap with GdiPlus: " + GetWinErrorMessage(SC)
      EndIf
      
      ; Libérer l'image GDI+
      GdipDisposeImage(*pImage)
    Else
      Debug "Unable to load image with GdiPlus: " + GetWinErrorMessage(SC)
    EndIf
    GdiplusShutdown(GdiplusToken)
  Else
    Debug "Error while initializing GdiPlus: " + GetWinErrorMessage(SC)
  EndIf
EndProcedure
;
Procedure ShowPictFromStgMedium(hWd, *StgMed.STGMEDIUM, Format = 0)
  ;
  ; Affiche le MetaFile ou l'ENHMetafile ou le Bitmap ou le DIB contenu dans le *StgMed
  ; dans la fenêtre hWd.
  ;
  ; Déclare une structure RECT pour stocker les dimensions du gadget/fenêtre
  Protected rect.RECT
  Protected XRatio.f, YRatio.f, SRatio.f
  Protected formatName$ = Space(256)
  GetClipboardFormatName_(Format, @formatName$, 256)
  Protected SupportedByGDI$ = ",PNG,JPG,JFIF,JPEG,TIFF,BMP,GIF,WMF,EMF,ICO,Windows Bitmap,"
  If FindString(SupportedByGDI$, "," + FormatName$ + ",")
    Protected Picture = 1
  Else
    Picture = 0
  EndIf
  ;
  ; Récupère les dimensions du gadget ou de la fenêtre
  If GetClientRect_(hWd, @rect)
    ; Calcule la largeur et la hauteur du gadget ou de la fenêtre
    Protected destWidth = rect\right - rect\left
    Protected destHeight = rect\bottom - rect\top
    Protected hdcWindow = GetDC_(hWd)
    Protected brush = GetStockObject_(#WHITE_BRUSH)
    ;
    FillRect_(hdcWindow, @rect, brush)
    DeleteObject_(brush)
    
    ; Vérifie si le STGMEDIUM contient un metafile
   If *StgMed And *StgMed\tymed = #TYMED_MFPICT
      ; Verrouille la mémoire pour accéder à la structure METAFILEPICT
      Protected *pMetaFile.METAFILEPICT = GlobalLock_(*StgMed\hMetaFilePict)
      If *pMetaFile
        ; Récupère les dimensions du metafile
        If *pMetaFile\hMF
          SRatio.f = *pMetaFile\xExt/*pMetaFile\yExt
          If SRatio < 1
            destWidth = destHeight*SRatio
          Else
            destHeight = destWidth/SRatio
          EndIf
          ; Définir le mode de mappage pour le contexte de périphérique
          SetMapMode_(hdcWindow, #MM_ANISOTROPIC) ; Permet l'ajustement de l'échelle
          SetViewportExtEx_(hdcWindow, destWidth, destHeight, 0)
          
          ; Affiche le contenu du metafile redimensionné dans la fenêtre ou le gadget
          PlayMetaFile_(hdcWindow, *pMetaFile\hMF)
        EndIf
        GlobalUnlock_(*StgMed\hMetaFilePict)
      EndIf

    ElseIf *StgMed And *StgMed\tymed = #TYMED_ENHMF
      If *StgMed\hEnhMetaFile
        ; Récupère le header du Enhanced metafile et ses dimensions
        Protected enhMFHeader.ENHMETAHEADER
        GetEnhMetaFileHeader_(*StgMed\hEnhMetaFile, SizeOf(ENHMETAHEADER), @enhMFHeader)
        ;
        XRatio.f = (enhMFHeader\rclbounds\right - enhMFHeader\rclbounds\left)/destWidth
        YRatio.f = (enhMFHeader\rclbounds\bottom - enhMFHeader\rclbounds\top)/destHeight
        If XRatio < YRatio
          XRatio = YRatio
        EndIf
        ;
        ; Définir le mode de mappage pour le contexte de périphérique
        Protected DispRect.rect
        DispRect\left = 0
        DispRect\top = 0
        DispRect\right = enhMFHeader\rclbounds\right/XRatio
        DispRect\bottom = enhMFHeader\rclbounds\bottom/XRatio
        ; Affiche le contenu de l'Enhanced Metafile redimensionné dans la fenêtre ou le gadget
        PlayEnhMetaFile_(hdcWindow, *StgMed\hEnhMetaFile, DispRect)
        ;
      EndIf
     ElseIf *StgMed And *StgMed\tymed = #TYMED_GDI And Format = #CF_BITMAP
      ShowBitmapPictInWindow(hWd, *StgMed\hBitmap)
      ;
    ElseIf *StgMed And *StgMed\tymed = #TYMED_HGLOBAL And Picture
      If *StgMed\hGlobal
        Protected *pStream.IStream
        If CreateStreamOnHGlobal_(*StgMed\hGlobal, #False, @*pStream) = #S_OK
          ShowStreamedPictInWindow(hWd, *pStream)
          *pStream\Release()
        EndIf
      EndIf
    ElseIf *StgMed And *StgMed\tymed = #TYMED_HGLOBAL And (Format = #CF_DIB Or Format = #CF_DIBV5)
      If *StgMed\hGlobal
        ; Verrouille la mémoire pour accéder à l'en-tête du DIB
        Protected *pDIB = GlobalLock_(*StgMed\hGlobal)
        If *pDIB
          ; Récupère les informations du DIB
          If Format = #CF_DIB
            Protected bmpInfo.BITMAPINFOHEADER
            CopyMemory(*pDIB, @bmpInfo, SizeOf(BITMAPINFOHEADER))
            Protected pWidth = bmpInfo\biWidth
            Protected pHeight = bmpInfo\biWidth
            Protected headerSize = bmpInfo\biSize
          Else
            Protected bmpV5Info.BITMAPV5HEADER
            CopyMemory(*pDIB, @bmpV5Info, SizeOf(BITMAPV5HEADER))
            pWidth = bmpV5Info\bV5Width
            pHeight = bmpV5Info\bV5Width
            headerSize = bmpV5Info\bV5Width
          EndIf
          
          ; Calcul du ratio pour conserver les proportions
          SRatio.f = pWidth / pHeight
          If SRatio < 1
            destWidth = destHeight * SRatio
          Else
            destHeight = destWidth / SRatio
          EndIf
          ;
          ; Crée un contexte de mémoire pour contenir le DIB
          Protected hdcMem = CreateCompatibleDC_(hdcWindow)
          If hdcMem
            ; Sélectionne et affiche le DIB redimensionné
            StretchDIBits_(hdcWindow, 0, 0, destWidth, destHeight, 0, 0, pWidth, pHeight, *pDIB + headerSize, *pDIB, #DIB_RGB_COLORS, #SRCCOPY)
            ; Nettoyer le contexte de mémoire
            DeleteDC_(hdcMem)
          EndIf
          
          ; Déverrouille la mémoire
          GlobalUnlock_(*StgMed\hGlobal)
        EndIf
      EndIf
    EndIf
    ReleaseDC_(hWd, hdcWindow)
  EndIf
  
EndProcedure
;
Procedure.s ReadStringFromMemory(MemAdr, sFormat = #PB_Unicode, CF_Format = 0)
  ;
  Protected Ret$, *DataBufferTemp
  ;
  Ret$ = PeekS(MemAdr, 1000, sFormat) ; taille limitée à 1000 caractères.
  If CF_Format = #CF_OEMTEXT
    *DataBufferTemp = AllocateMemory((Len(Ret$) + 1)*2)
    If *DataBufferTemp
      ; Puisque nous avons limité la taille de la chaîne lue à 1000 caractères,
      ; on refait un PokeS de la chaîne tronquée à l'adresse de départ, 
      ; afin de nous assurer que OemToChar ne dépasse pas la taille du buffer
      ; que nous lui avons alloué:
      PokeS(MemAdr, Ret$, - 1, #PB_Ascii)
      ;
      OemToChar_(MemAdr, *DataBufferTemp)
      Ret$ = PeekS(*DataBufferTemp, 1000)
      FreeMemory(*DataBufferTemp)
      Ret$ = ReplaceString(Ret$,Chr(9834),Chr(13))
      Ret$ = ReplaceString(Ret$,Chr(9689),Chr(10))
    EndIf
  EndIf
  Ret$ = ReplaceString(Ret$, Chr(13), "¶")
  Ret$ = ReplaceString(Ret$, Chr(10), "")
  ProcedureReturn Ret$
EndProcedure
;
Procedure.s FormatHexFromL(Number, Length)
  ; Creates a string representing a number in hexadecimal form.
  ;
  Protected Arg, Ret$
  ;
  If Length = 8 : Arg = #PB_Quad
  ElseIf Length = 4 : Arg = #PB_Word
  ElseIf Length = 2 : Arg = #PB_Byte
  Else : IDO_RegisterResults("FormatHexFromL: Asked Length not implemented in FormatHexFromL")
    ProcedureReturn ""
  EndIf
  Ret$ = Hex(Number, Arg)
  ProcedureReturn "$"+RSet(Ret$, Length, "0")
EndProcedure
;
Procedure.s AnalyseStringFromMemory(*Buffer, BufferSize)
  ;
  ; Based on a simple memory pointer, this procedure
  ; will attempt to determine if it points to a string
  ; and whether the string is in Unicode or ASCII.
  ;
  Protected lbyte, Chrlbyte$, str$
  ;
  If *Buffer
    Protected ReadLimit = BufferSize
    If ReadLimit > 20 : ReadLimit = 20 : EndIf
    ; Examines the memory byte by byte, counting
    ; the zeros to identify Unicode strings, and
    ; stacking the hexadecimal version of the bytes read in Hexstr$:
    Protected Hexstr$ = ""
    Protected Nb0 = 0
    Protected ct
    For ct = 0 To ReadLimit - 1
      lbyte = PeekB(*Buffer + ct)
      If lbyte < 0  : lbyte + 256 : EndIf
      If lbyte > 31 And lbyte < 128 Or lbyte > 159
        Chrlbyte$ = ":" + Chr(lbyte)
      Else 
        Chrlbyte$ = ""
      EndIf
      Hexstr$ + ReplaceString(FormatHexFromL(lByte,2), "$", "") + Chrlbyte$ + " "
      If lbyte = 0
        Nb0 + 1
      EndIf
    Next
    ;
    If Nb0 > ReadLimit * 0.4
      ; Nearly half of the bytes read are zeros.
      ; We assume it is a Unicode string.
      str$ = " / ''" + ReadStringFromMemory(*Buffer, #PB_Unicode) + "''."
    Else
      ; We assume it is an ASCII or Utf8 string.
      str$ = " / ''" + ReadStringFromMemory(*Buffer, #PB_Ascii) + "''."
      If FindString(str$, "Ã") Or FindString(str$, "Å") Or FindString(str$, "À") Or FindString(str$, "Á") Or FindString(str$, "Â") Or FindString(str$, "Ä")
        ; It seems that we get an UTF8 string.
        str$ = " / ''" + ReadStringFromMemory(*Buffer, #PB_UTF8) + "''."
        If FindString(str$, Chr(65533))
          ; Ooops! perhaps, it's not UTF8
          str$ = " / ''" + ReadStringFromMemory(*Buffer, #PB_Ascii) + "''."
        EndIf
      EndIf
    EndIf
    ; 
    If Len(str$) < 20
      ; The string is short, so it may not be a string.
      ; We will add the hexadecimal presentation of the bytes read.
      str$ + " / " + Hexstr$
      If ReadLimit < BufferSize
        ; We have only read part of the memory.
        str$ + "..."
      Else
        ; We have read the entire memory.
        str$ + "."
      EndIf
    EndIf
    ;
  EndIf
  ;
  ProcedureReturn str$
EndProcedure
;
Procedure.s ReadFirstBytesFromStream(*pStream.IStream, NumBytes.q, Canvas = 0)
  Protected *Buffer
  Protected BytesRead.l
  Protected pos.q, Ret$
  ;
  If *pStream
    If Canvas
      ShowStreamedPictInWindow(GadgetID(Canvas), *pStream)
    Else
      If *pStream\Seek(0, #STREAM_SEEK_END, @pos.q) = #S_OK
        If NumBytes = -1 Or NumBytes > pos
          NumBytes = pos
        EndIf
      EndIf
      ;
      If NumBytes < 1 : NumBytes = 40 : EndIf
        
      ; Allocate a buffer to read the bytes
      *Buffer = AllocateMemory(NumBytes)
      If *Buffer = 0
        Debug "Memory allocation error."
        ProcedureReturn
      EndIf
      ;
      ; Read the first bytes from the stream
      If *pStream\Seek(0, #STREAM_SEEK_SET, 0) = #S_OK
        If *pStream\Read(*Buffer, NumBytes, @BytesRead)  = #S_OK
          Ret$ = AnalyseStringFromMemory(*Buffer, NumBytes)
        Else
          Debug "Error while reading the IStream."
        EndIf
      Else
        Debug "Error while reading the IStream."
      EndIf
      FreeMemory(*Buffer)
    EndIf
  Else
    Debug "Invalid parameter: *pStream is null."
  EndIf
  
  ProcedureReturn Ret$
  ; 
EndProcedure
;
Structure STATSTG
  pwcsName.i        ; Pointeur vers le nom de l'objet (wide string).
  type.l            ; Type de l'objet (STGTY_STORAGE, STGTY_STREAM, etc.).
  cbSize.q          ; Taille de l'objet en octets.
  mtime.FILETIME    ; Date et heure de la dernière modification.
  ctime.FILETIME    ; Date et heure de la création.
  atime.FILETIME    ; Date et heure du dernier accès.
  grfMode.l         ; Mode d'accès utilisé pour ouvrir l'objet.
  grfLocksSupported.l ; Type de verrouillage supporté par l'objet.
  clsid.GUID        ; Identifiant de la classe (CLSID) pour le stockage.
  grfStateBits.l    ; Bits d'état actuels de l'objet de stockage.
  reserved.l        ; Réservé pour un usage futur (doit être zéro).
EndStructure
;
Procedure.s ReadFirstBytesFromStorage(*pStorage.IStorage, NumBytes, Canvas = 0)
  ;
  Protected *pEnum.IEnumSTATSTG
  Protected statStg.STATSTG
  Protected result
  Protected count.l = 0
  Protected *pStream.IStream
  Protected TypePrefixe$, Ret$
  ;
  ; Get an enumerator for the storage elements
  result = *pStorage\EnumElements(0, 0, 0, @*pEnum)
  If result <> #S_OK
    Debug "Failed to enumerate storage elements. Error: " + Str(result)
    ProcedureReturn
  EndIf
  ;
  ; Loop through the enumerator to find streams
  While *pEnum\Next(1, @statStg, 0) = #S_OK
    count + 1
    
    ; Check the type of element (stream or storage)
    Select statStg\type
      Case #STGTY_STREAM
        TypePrefixe$ = Chr(13) + "    • IStream named ''"+PeekS(statStg\pwcsName, -1, #PB_Unicode)+"''"
        If PeekS(statStg\pwcsName, -1, #PB_Unicode)
          ; Open the stream
          result = *pStorage\OpenStream(statStg\pwcsName, 0, #STGM_READ | #STGM_SHARE_EXCLUSIVE, 0, @*pStream)
          If result = #S_OK
            If Canvas
              ShowStreamedPictInWindow(GadgetID(Canvas), *pStream)
            Else
              Ret$ + TypePrefixe$ + ReadFirstBytesFromStream(*pStream, NumBytes, Canvas)
            EndIf
            ; Release the stream
            *pStream\Release()
          Else
            Debug "Failed to open the IStream ''" + PeekS(statStg\pwcsName, -1, #PB_Unicode) + "'' in the IStorage: " + GetWinErrorMessage(result)
          EndIf
        EndIf
        
      Case #STGTY_STORAGE
        Ret$ + Chr(13) + "    • IStorage named ''"+PeekS(statStg\pwcsName, -1, #PB_Unicode)+"''."
      Case #STGTY_LOCKBYTES 
        Ret$ + Chr(13) + "    • LockBytes content named ''"+PeekS(statStg\pwcsName, -1, #PB_Unicode)+"''."
      Case #STGTY_PROPERTY  
        Ret$ + Chr(13) + "    • Property content named ''"+PeekS(statStg\pwcsName, -1, #PB_Unicode)+"''."
        ;
      Default
        Ret$ + Chr(13) + "    • Unknown type data named ''"+PeekS(statStg\pwcsName, -1, #PB_Unicode)+"''."
        ;
    EndSelect
    ; Free the name string
    CoTaskMemFree_(statStg\pwcsName)
  Wend
  
  ; Clean up
  *pEnum\Release()
  
  ProcedureReturn Ret$
EndProcedure
;
Procedure.s EnumFormatsFromIDataObject(*pDataObject.IDataObject, PrintIt = 1, Canvas1 = 0, Canvas2 = 0, Canvas3 = 0)
  ;
  ; Enumerates the data contained in an IDataObject and provides
  ; a brief overview.
  ; If a Gadget with the number Canvas1 exists, it will be filled
  ; with the MetaFile image found in the IDataObject.
  ; If a Gadget with the number Canvas2 exists, it will be filled
  ; with the Bitmap or DIB/DIBV5 image found in the IDataObject.
  ; If a Gadget with the number Canvas3 exists, it will be filled
  ; with the formats PNG, JPG, JPEG, TIFF, BMP, GIF, WMF, EMF, ICO, Windows Bitmap
  ; found in the IDataObject.
  ; If PrintIt = 1, the list of found formats will be displayed in
  ; the 'Debug' window. In all cases, it will be included in
  ; the return value.
  ;
  Protected *enumFormat.IEnumFORMATETC, stgm.STGMEDIUM
  Protected formatEtc.FORMATETC
  Protected sc.l, Ret$, tx$
  Protected ENHMetafile = 0
  ;
  If *pDataObject = 0
    MessageRequester("Oops!", "EnumFormatsFromIDataObject error: Parameter is null.")
    ProcedureReturn
  EndIf
  ;
  If Canvas1 And IsGadget(Canvas1)
    ; On efface le gagdet servant à afficher les images du IDataObject.
    ShowPictFromStgMedium(GadgetID(Canvas1), 0)
  EndIf
  If Canvas2 And IsGadget(Canvas2)
    ; On efface le gagdet servant à afficher les images du IDataObject.
    ShowPictFromStgMedium(GadgetID(Canvas2), 0)
  EndIf
  If Canvas3 And IsGadget(Canvas3)
    ; On efface le gagdet servant à afficher les images du IDataObject.
    ShowPictFromStgMedium(GadgetID(Canvas3), 0)
  EndIf
  ;
  Ret$ =   "____________________________________________________________" + Chr(13)
  ;
  ; Obtenir l'énumérateur de formats du IDataObject
  SC = *pDataObject\EnumFormatEtc(#DATADIR_GET, @*enumFormat)
  If SC = #S_OK And *enumFormat
    ;
    Ret$ + "  ***** Available formats found in the IDataObject : *****" + Chr(13)
    Ret$ + "____________________________________________________________" + Chr(13)
    ;
    ; Parcourir tous les formats disponibles
    While *enumFormat\Next(1, @formatEtc, #Null) = #S_OK
      *pDataObject\getData(formatEtc, @stgm.STGMEDIUM)
      Protected Format = formatEtc\cfFormat
      If Format < 0 : Format + 65536 : EndIf
      ; Obtenir le nom du format
      Protected FormatName$ = GetFormatName(Format)
      Protected SupportedByGDI$ = ",PNG,JPG,JPEG,JFIF,TIFF,BMP,GIF,WMF,EMF,ICO,Windows Bitmap,"
      If FindString(SupportedByGDI$, "," + FormatName$ + ",")
        Protected Picture = 1
      Else
        Picture = 0
      EndIf
      ;
      tx$ = " • " + FormatName$ + "/" + GetTymedName(stgm\tymed) + " / " + GetTymedName(formatEtc\tymed)
      ;
      If Format = #CF_LOCALE Or Format = #CF_OEMTEXT Or Format = #CF_TEXT Or Format = #CF_UNICODETEXT
        ;
        If stgm\tymed = #TYMED_HGLOBAL
          ;
          ; Obtenir le handle de la mémoire globale
          Protected *pGlobalMemory = GlobalLock_(stgm\hGlobal)
          If *pGlobalMemory
            If Format = #CF_OEMTEXT Or Format = #CF_TEXT
              tx$ + " / ''" + ReadStringFromMemory(*pGlobalMemory, #PB_Ascii, Format) + "''"
            ElseIf Format = #CF_LOCALE
              Protected dLCID = PeekL(*pGlobalMemory)
              Protected languageName.s = Space(100)
              If GetLocaleInfo_(dLCID, #LOCALE_SLANGUAGE, @languageName, 100) > 0
                tx$ + " : " + languageName
              Else
                tx$ + " : Unknown langage"
              EndIf
            Else;If Format = #CF_UNICODETEXT
              tx$ + " / ''" + ReadStringFromMemory(*pGlobalMemory) + "''"
            EndIf
          EndIf
          GlobalUnlock_(stgm\hGlobal)
        EndIf
        ;
      ElseIf Format = #CF_HDROP
        tx$ +  Chr(13) + "    • " + ReplaceString(HandleToFilesList(stgm\hGlobal), Chr(10), Chr(13) + "    • ")
        ;
      ElseIf stgm\tymed = #TYMED_FILE
        tx$ + " / ''" + PeekS(stgm\lpszFileName, -1, #PB_Unicode) + "''."
        ;
      ElseIf stgm\tymed = #TYMED_MFPICT Or stgm\tymed = #TYMED_ENHMF Or stgm\tymed = #TYMED_GDI Or (stgm\tymed And (Format = #CF_DIB Or Format = #CF_DIBV5))
        tx$ + " / See the picture below."
        ;
        If Canvas1 And IsGadget(Canvas1) And ((Format = #CF_METAFILEPICT And ENHMetafile = 0) Or Format = #CF_ENHMETAFILE)
          If Format = #CF_ENHMETAFILE : ENHMetafile = 1 : EndIf
          ShowPictFromStgMedium(GadgetID(Canvas1), stgm)
        EndIf
        If Canvas2 And IsGadget(Canvas2) And (Format = #CF_DIB Or Format = #CF_DIBV5 Or Format = #CF_BITMAP)
          ShowPictFromStgMedium(GadgetID(Canvas2), stgm, Format)
        EndIf
        ;
      ElseIf stgm\tymed = #TYMED_ISTREAM
        If Picture And Canvas3 And IsGadget(Canvas3)
          tx$ + " / See the picture below."
          ReadFirstBytesFromStream(stgm\pstm, 100, Canvas3)
        Else
          tx$ + ReadFirstBytesFromStream(stgm\pstm, 100)
        EndIf
        ;
      ElseIf stgm\tymed = #TYMED_ISTORAGE
        If Picture And Canvas3 And IsGadget(Canvas3)
          tx$ + " / See the picture below."
          ReadFirstBytesFromStorage(stgm\pstg, 100, Canvas3)
        Else
          tx$ + ReadFirstBytesFromStorage(stgm\pstg, 100)
        EndIf
      ElseIf stgm\tymed And stgm\hGlobal And GlobalSize_(stgm\hGlobal)
        ;
        If Picture And Canvas3 And IsGadget(Canvas3)
          tx$ + " / See the picture below."
          ShowPictFromStgMedium(GadgetID(Canvas3), stgm, Format)
        Else
          ;
          ; On ne sait pas a quel type de données on a affaire.
          ; On va quand même essayer de les lire comme s'il 
          ; s'agissait de caractères, pour voir ce que ça donne:
          ;
          tx$ + AnalyseStringFromMemory(GlobalLock_(stgm\hGlobal), GlobalSize_(stgm\hGlobal))
          GlobalUnlock_(stgm\hGlobal)
        EndIf
        ;
      ElseIf stgm\hGlobal <> 0
        tx$ + " / hGlobal = " + Str(stgm\hGlobal)
      ElseIf stgm\tymed = #Null Or stgm\hGlobal = 0
        tx$ + " / stgm\hGlobal = " + Str(stgm\hGlobal) + " / StgMedium\pUnkForRelease = " + Str(stgm\pUnkForRelease) + " / Format\dwAspect = " + Str(formatEtc\dwAspect) + " / Format\ptd = " + Str(formatEtc\ptd) + " / Format\lindex = " + Str(formatEtc\lindex)
      Else
        tx$ + "stgm\hGlobal = "+Str(stgm\hGlobal)
      EndIf
      ;
      If tx$
        Ret$ + tx$ + Chr(13)
      EndIf
      ReleaseStgMedium_(stgm)
    Wend
    ;
    ; Libérer l'énumérateur
    *enumFormat\Release()
  Else
    Ret$ = "Error : Unable to open format enumerator."
  EndIf
  Ret$ + "____________________________________________________________" + Chr(13)
  ;
  If PrintIt
    Debug Ret$
  EndIf
  ProcedureReturn Ret$
EndProcedure
;
;
Procedure GetFORMATETCFromIDataObject(*pDataObject.IDataObject, Format, *FormatEtc.FORMATETC)
  ;
  ; Explore les divers formats proposés par le IDataObject jusqu'à trouver celui qui
  ; correspond à 'Format'. Si ce format est trouvé, la structure FORMATETC correspondante
  ; sera retournée dans *FormatEtc.FORMATETC.
  ; 
  Protected *enumFormat.IEnumFORMATETC
  Protected sc.l

  ; Obtenir l'énumérateur de formats du IDataObject
  sc = *pDataObject\EnumFormatEtc(#DATADIR_GET, @*enumFormat)
  
  If sc = #S_OK And *enumFormat
    ; Parcourir tous les formats disponibles
    While *enumFormat\Next(1, *formatEtc, #Null) = #S_OK
      If *formatEtc\cfFormat = Format
        *enumFormat\Release()
        Debug "GetFORMATETCFromIDataObject: Format renseigné : " + GetFormatName(Format)
        ProcedureReturn #S_OK
      EndIf
      If *formatEtc\ptd
        CoTaskMemFree_(*formatEtc\ptd)
      EndIf
    Wend
    ; Libérer l'énumérateur
    *enumFormat\Release()
  Else
    Debug "GetFORMATETCFromIDataObject: Erreur : Impossible d'obtenir l'énumérateur de formats."
    If SC = 0 : SC = 1 : EndIf
    ProcedureReturn SC
  EndIf
EndProcedure
;
Procedure GetDataFromIDataObjet(*pDataObject.IDataObject, Format)
  ;
  ; Explore les divers formats proposés par le IDataObject jusqu'à trouver celui qui
  ; correspond à 'Format'. Si ce format est trouvé, les données correspondantes
  ; seront retournées dans un buffer.
  ;
  ; Exemple d'utilisation : *Buffer = GetDataFromIDataObjet(*pDataObject.IDataObject, #CF_TEXT)
  ;  -> Retourne un pointeur mémoire vers les données #CF_TEXT
  ;     Ce pointeur devra faire l'objet d'un FreeMemory(*Buffer) après utilisation.
  ;
  ;     Pour l'exemple #CF_TEXT donné ci-dessus, il faut savoir que les données en question
  ;     correspondent à celles d'une chaîne en ASCII. Il faudra donc faire 
  ;           PeekS(*Buffer, -1, #PB_ASCII)
  ;     pour récupérer le texte correspondant.
  ;
  ; ATTENTION : Cette procédure est purement utilitaire et fournie à titre d'exemple sur
  ; la façon de récupérer des données d'un IDataObject.
  ;
  Protected ObjFormat.FORMATETC
  Protected stgm.STGMEDIUM
  Protected SC, hGlobalMemory, *pGlobalMemory, BufferSize, *Buffer, tx$
  ;
  SC = GetFORMATETCFromIDataObject(*pDataObject, Format, ObjFormat.FORMATETC)
  If SC <> #S_OK
    Debug "GetDataFromIDataObjet: Format non présent dans l'objet"
  Else
    SC = *pDataObject\getData(ObjFormat, @stgm)
    If SC = #S_OK
      Debug "GetDataFromIDataObjet: stgm\tymed = " + GetTymedName(stgm\tymed)
      If stgm\tymed = #TYMED_HGLOBAL
        ; Obtenir le handle de la mémoire globale
        hGlobalMemory = stgm\hGlobal
        
        ; Verrouiller la mémoire globale pour y accéder
        *pGlobalMemory = GlobalLock_(hGlobalMemory)
        
        If *pGlobalMemory = 0
          Debug "GetDataFromIDataObjet: Unable to get memory from hGlobal"
        Else
          ; Obtenir la taille de la mémoire globale
          BufferSize = GlobalSize_(hGlobalMemory)
          
          ; Allouer de la mémoire pour les données
          *Buffer = AllocateMemory(BufferSize)
          Debug "BufferSize = " + BufferSize
          
          If *Buffer
            ; Copier les données depuis la mémoire globale
            CopyMemory(*pGlobalMemory, *Buffer, BufferSize)
            If MemorySize(*Buffer) = BufferSize
              tx$ = "GetDataFromIDataObjet: Données lues avec succès à partir de la mémoire globale : " + Str(GlobalSize_(hGlobalMemory)) + " octets."
              Debug tx$
              ProcedureReturn *Buffer
            EndIf
          EndIf
        EndIf
        GlobalUnlock_(hGlobalMemory)
      EndIf
    EndIf
  EndIf
  ProcedureReturn 0
EndProcedure
;
Procedure.s GetProgIDFromCLSID(*clsid)
  Protected ProgID.s
  Protected *lplpszProgID
  
  ; Appel de ProgIDFromCLSID pour obtenir le ProgID associé au CLSID
  If ProgIDFromCLSID_(*clsid, @*lplpszProgID) = #S_OK
    ProgID = PeekS(*lplpszProgID, -1, #PB_Unicode)
    CoTaskMemFree_(*lplpszProgID)  ; Libérer la mémoire allouée par COM
    ProcedureReturn ProgID
  EndIf
  
  ProcedureReturn "ProgID not found"
EndProcedure
;
Procedure.s ProgNameFromCLSID(MyCLSID)
  ;
  Protected *Buffer, ct, Slen, sk$, Ret, hKey, cSize, *szPath, File$
  ;
  *Buffer = AllocateMemory(100)
  For ct = 1 To Len("CLSID\") ; Write "CLSID\" in Unicode Mode
    PokeB(*Buffer+ct*2-2,Asc(Mid("CLSID\",ct,1)))
    PokeB(*Buffer+ct*2-1,0)
  Next
  Slen = StringFromGUID2_(MyCLSID,*Buffer+Len("CLSID\")*2,100)*2 ; add the CLSID String (always coded in Unicode)
  Slen+Len("CLSID\")*2
  sk$ = ""
  For ct = 1 To SLen Step 2 ; Get the string in Unicode OR Ascii depending on our compilation mode
    sk$ + Chr(PeekC(*Buffer+ct-1))
  Next
  FreeMemory(*Buffer)
  If SLen
    Ret = RegOpenKeyEx_(#HKEY_CLASSES_ROOT,@sk$, 0, #KEY_ALL_ACCESS, @hKey)
    If (Ret =#ERROR_SUCCESS)
      ; Query value of key To get Path And close the key
      Ret = RegQueryValueEx_(hKey, #Null, #Null, #Null, #Null, @cSize)
      If (Ret = #ERROR_SUCCESS)
        *szPath = AllocateMemory(cSize)
        Ret = RegQueryValueEx_(hKey, #Null, #Null, #Null, *szPath, @cSize)
        If (Ret = #ERROR_SUCCESS)
          RegCloseKey_(hKey);
          File$ = PeekS(*szPath)
          FreeMemory(*szPath)
        EndIf
      EndIf
    EndIf
  EndIf
  If (Ret <>#ERROR_SUCCESS)
    File$ = GetWinErrorMessage(Ret)
  EndIf
  ProcedureReturn File$
EndProcedure
;
Procedure.s GetClsidFromObject_AsPBDataSection(*Object.IUnknown)
  ; Return a string contained a PureBasic DataSection
  ; representing the CLSid of '*Object'.
  ;
  Protected SC, Ret$, ct
  ;
  ; Déclaration d'un GUID pour stocker le CLSID
  DataSection
    IID_IPersist:
      Data.l $0000010c
      Data.w $0000, $0000
      Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  EndDataSection

  ; Obtenir l'interface IPersist
  Protected oPersist.IPersist
  SC = *Object\QueryInterface(?IID_IPersist, @oPersist)
  If SC = #S_OK
     ; Obtenir le CLSID
    Protected ClassID.CLSID
    oPersist\GetClassID(@ClassID)
    Ret$ = "DataSection" + Chr(13)
    Ret$ + "  CLSID_Object:" + Chr(13)
    Ret$ + "    Data.l " + FormatHexFromL(ClassID\Data1, 8) + Chr(13)
    Ret$ + "    Data.w " + FormatHexFromL(ClassID\Data2, 4) + ", " + FormatHexFromL(ClassID\Data3, 4) + Chr(13)
    Ret$ + "    Data.b "
    For ct = 1 To 8
      Ret$ + FormatHexFromL(ClassID\Data4[ct-1], 2)
      If ct < 8
        Ret$ + ", "
      EndIf
    Next
    ProcedureReturn Ret$ + Chr(13) + "EndDataSection"
  Else
    IDO_RegisterResults("Failed to get IPersist interface: " + GetWinErrorMessage(SC)+".")
    ProcedureReturn ""
  EndIf
EndProcedure
;
Procedure PrintFormatETC(*MyFormatEtc.FormatEtc)
  Protected dwAspect$
  ;
  Debug "____________________________________"
  Debug "            FormatETC :"
  Debug "cfFormat.w = " + GetFormatName(*MyFormatEtc\cfFormat)
  Debug "ptd.DVTARGETDEVICE = " + Str(*MyFormatEtc\ptd)
  If *MyFormatEtc\dwAspect = 1
    dwAspect$ = "DVASPECT_CONTENT"
  ElseIf *MyFormatEtc\dwAspect = 2
    dwAspect$ = "DVASPECT_THUMBNAIL"
  ElseIf *MyFormatEtc\dwAspect = 4
    dwAspect$ = "DVASPECT_ICON"
  ElseIf *MyFormatEtc\dwAspect = 8
    dwAspect$ = "DVASPECT_DOCPRINT"
  EndIf
  Debug "dwAspect.l = " + dwAspect$
  Debug "lindex = " + Str(*MyFormatEtc\lindex)
  Debug "tymed = " + GetTymedName(*MyFormatEtc\tymed)
  Debug "____________________________________"
EndProcedure
;
Procedure PrintFormatETCFromDataObject(*pDataObject.IDataObject, Format)
  ;
  Protected SC, MyFormatEtc.FORMATETC
  ;
  SC = GetFORMATETCFromIDataObject(*pDataObject, Format, MyFormatEtc)
  If SC
    IDO_RegisterResults(GetWinErrorMessage(SC))
  Else
    PrintFormatETC(@MyFormatEtc)
  EndIf
EndProcedure
;
Procedure PrintSTGMEDIUM(*MySTGMedium.STGMEDIUM, Format = -1)
  ;
  Protected MemName$, hGlobalMemory, *pGlobalMemory, BufferSize, *Buffer, tx$
  ;
  Debug "____________________________________"
  Debug "            STGMedium :"
  Debug "tymed = " + GetTymedName(*MySTGMedium\tymed)
  MemName$ = ReplaceString(GetTymedName(*MySTGMedium\tymed), "TYMED_", "")
  If MemName$ = "GDI" : MemName$ + "/Bitmap" : EndIf
  Debug MemName$ + " / Adr : " + Str(*MySTGMedium\hGlobal)
  
  If *MySTGMedium\tymed = #TYMED_HGLOBAL
    hGlobalMemory = *MySTGMedium\hGlobal
    
    ; Verrouiller la mémoire globale pour y accéder
    *pGlobalMemory = GlobalLock_(hGlobalMemory)
    
    If *pGlobalMemory
      ; Obtenir la taille de la mémoire globale
      BufferSize = GlobalSize_(hGlobalMemory)
      
      ; Allouer de la mémoire pour les données
      *Buffer = AllocateMemory(BufferSize)
      
      If *Buffer
        ; Copier les données depuis la mémoire globale
        CopyMemory(*pGlobalMemory, *Buffer, BufferSize)
        tx$ = "   Données lues avec succès à partir de la mémoire globale : " + Str(GlobalSize_(hGlobalMemory)) + " octets."
        If Format = #CF_TEXT
          tx$ + " / ''" + PeekS(*Buffer, -1, #PB_Ascii) + "''"
        ElseIf Format = #CF_UNICODETEXT
          tx$ + " / ''" + PeekS(*Buffer, -1, #PB_Unicode) + "''"
        EndIf
        Debug Tx$
        FreeMemory(*Buffer)
      EndIf
    EndIf
    GlobalUnlock_(hGlobalMemory)
  EndIf

  Debug "pUnkForRelease = " + Str(*MySTGMedium\pUnkForRelease)
  Debug "____________________________________"
EndProcedure
;
Procedure CloneIDataObject(*IDOSource.IDataObject, *IDODest.IDataObject)
  ;
  Protected *enumFormat.IEnumFORMATETC, SC
  Protected formatEtc.FormatEtc, stgm.StgMedium
  ;
  SC = *IDOSource\EnumFormatEtc(#DATADIR_GET, @*enumFormat)
  If SC = #S_OK And *enumFormat
    ;
    ; Parcourir tous les formats disponibles
    While *enumFormat\Next(1, @formatEtc.FormatEtc, #Null) = #S_OK
      SC = *IDOSource\getData(formatEtc, @stgm.StgMedium)
      If SC = #S_OK
        SC = *IDODest\SetData(formatEtc, stgm, #True)
        If SC <> #S_OK
          Debug "Error while setting data: " + GetWinErrorMessage(SC)
        EndIf
      Else
        Debug "Error while getting data: " + GetWinErrorMessage(SC)
      EndIf
    Wend
    ;
    ; Libérer l'énumérateur
    *enumFormat\Release()
  Else
    Debug "Error : Unable to open format enumerator."
  EndIf
EndProcedure
;
;
;
;***************************************************************************
;
;                                    TEST
;
;***************************************************************************
;
SetClipboardText("This is the old content of clipboard")
;
; Get the clipboard content and clone it:
OleFlushClipboard_() ; Ensure that clipboard has completed its data and released old owner.
OleGetClipboard_(@*pClipboardData.IDataObject)
;
; Clone it:
MemIDataObject.IDataObject = CreateIDataObject()
CloneIDataObject(*pClipboardData, MemIDataObject)
*pClipboardData\Release()
;
;
; Create a new IDataObject:
MyIDataObject.IDataObject = CreateIDataObject()
SetIDataObjectData_Helper(MyIDataObject, #CF_UNICODETEXT, 0, 0, "Hello Word!")
; Fill the clipboard with our IDataObject
OleSetClipboard_(MyIDataObject)

  
If OpenWindow(0, 0, 0, 600, 380, "Do 'past' (CTRL + V)", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  SetWindowLong_(WindowID(0),#GWL_STYLE,GetWindowLong_(WindowID(0),#GWL_STYLE)|#WS_CLIPCHILDREN)
 
  EGadget = EditorGadget(#PB_Any, 10, 10, 580, 360)
  SetActiveGadget(EGadget)
  Repeat
    Event = WaitWindowEvent()
    
  Until Event = #PB_Event_CloseWindow
EndIf
;
; Clean up:
DestroyIDataObject(MyIDataObject)
;
; Restore the clipboard content:
OleSetClipboard_(MemIDataObject)
OleFlushClipboard_() ; This command will release MemIDataObject after having transfered definitely its content to clipboard.
;
If OpenWindow(0, 0, 0, 600, 380, "Do 'past' again, to see old clipboard content!", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  SetWindowLong_(WindowID(0),#GWL_STYLE,GetWindowLong_(WindowID(0),#GWL_STYLE)|#WS_CLIPCHILDREN)
 
  EGadget = EditorGadget(#PB_Any, 10, 10, 580, 360)
  SetActiveGadget(EGadget)
  Repeat
    Event = WaitWindowEvent()
    
  Until Event = #PB_Event_CloseWindow
EndIf

[Kwai chang caine]

Un sacré code, merci à vous deux
J'ai jamais bien compris ce que c'était bien que j'ai lu souvent ce mot, je suppose que c'est encore une des fonctions "simple" made in microsoft comme l'OLE et autres joyeuseries