Code: Select all
; ***************************************************************************
;
; Examine Cliboard data
;
; List all data contained in the clipboard
; For Windows only
; PB 6.11 - By Zapman Sept 2024
;
; ***************************************************************************
;
; For each data, this program try to know more about it, to read strings
; of any type and to print picture of any type.
;
; It can be a help to learn how to convert pictures from any format, or how
; to deal with the IStream and IStorage interfaces.
;
;
Procedure.s GetWinErrorMessage(errorCode)
;
; Retourne un texte qui explicite l'erreur dont le numéro
; est passé dans le paramètre 'errorCode'.
:
Protected messageBuffer$ = Space(256) ; Buffer pour le message
Protected messageLength
messageLength = FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM | #FORMAT_MESSAGE_IGNORE_INSERTS, #Null, errorCode, 0, @messageBuffer$, 256, #Null)
If messageLength > 0
; Supprime les retours à la ligne à la fin du message
messageBuffer$ = ReplaceString(messageBuffer$, Chr(10), "")
messageBuffer$ = ReplaceString(messageBuffer$, Chr(13), "")
messageBuffer$ = Trim(messageBuffer$)
Else
messageBuffer$ = "Unknown error code:"
EndIf
ProcedureReturn messageBuffer$ + " ($" + Hex(errorCode) + ")"
EndProcedure
;
Procedure WtoUnsignedI(number.w)
Protected Result = number
;
If Result < 0
Result + 65536
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure.s GetFormatName(cfFormat.w)
;
; Retourne un nom de format en fonction du code passé dans cfFormat
;
Protected formatName$ = Space(256)
Protected Format = WtoUnsignedI(cfFormat)
;
Select Format
; Formats standards
Case #CF_TEXT : formatName$ = "CF_TEXT"
Case #CF_BITMAP : formatName$ = "CF_BITMAP"
Case #CF_METAFILEPICT : formatName$ = "CF_METAFILEPICT"
Case #CF_SYLK : formatName$ = "CF_SYLK"
Case #CF_DIF : formatName$ = "CF_DIF"
Case #CF_TIFF : formatName$ = "CF_TIFF"
Case #CF_OEMTEXT : formatName$ = "CF_OEMTEXT"
Case #CF_DIB : formatName$ = "CF_DIB"
Case #CF_PALETTE : formatName$ = "CF_PALETTE"
Case #CF_PENDATA : formatName$ = "CF_PENDATA"
Case #CF_RIFF : formatName$ = "CF_RIFF"
Case #CF_WAVE : formatName$ = "CF_WAVE"
Case #CF_UNICODETEXT : formatName$ = "CF_UNICODETEXT"
Case #CF_ENHMETAFILE : formatName$ = "CF_ENHMETAFILE"
Case #CF_HDROP : formatName$ = "CF_HDROP"
Case #CF_LOCALE : formatName$ = "CF_LOCALE"
Case #CF_DIBV5 : formatName$ = "CF_DIBV5"
Default
GetClipboardFormatName_(Format, @formatName$, 256)
EndSelect
;
If formatName$ = ""
formatName$ = "Unknown format (" + Str(Format) + ")"
EndIf
;
ProcedureReturn formatName$
EndProcedure
;
Procedure.s GetTymedName(Tymed)
;
; Retourne le nom de la constante dont la valeur est passée dans le paramètre 'Tymed'.
;
Protected Tymed$ = ""
;
If Tymed = 0
tymed$ = "TYMED_NULL"
Else
If Tymed & 1
Tymed$ + "TYMED_HGLOBAL + "
EndIf
If Tymed & 2
Tymed$ + "TYMED_FILE + "
EndIf
If Tymed & 4
Tymed$ + "TYMED_ISTREAM + "
EndIf
If Tymed & 8
Tymed$ + "TYMED_ISTORAGE + "
EndIf
If Tymed & 16
Tymed$ + "TYMED_GDI + "
EndIf
If Tymed & 32
Tymed$ + "TYMED_MFPICT + "
EndIf
If Tymed & 64
Tymed$ + "TYMED_ENHMF"
EndIf
EndIf
If Tymed$ = ""
tymed$ = "Unknown tymed value: " + Str(Tymed)
EndIf
If Right(Tymed$, 3) = " + "
Tymed$ = Left(Tymed$, Len(Tymed$) - 3)
EndIf
ProcedureReturn Tymed$
EndProcedure
;
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 ShowBitmapPictInWindow(hWd, hBitmap)
;
; Draw the hBitmap into hWd
;
Protected hdcWindow = GetDC_(hWd)
Protected rect.RECT, SRatio.f
GetClientRect_(hWd, @rect)
; Calculates the width and height of the gadget or window
Protected destWidth = rect\right - rect\left
Protected destHeight = rect\bottom - rect\top
If hBitmap
; Retrieves the 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
;
; Creates a memory context to hold the bitmap
Protected hdcMem = CreateCompatibleDC_(hdcWindow)
If hdcMem
; Selects the bitmap into the memory context
Protected oldBmp = SelectObject_(hdcMem, hBitmap)
; Copies the resized bitmap into the window or gadget
StretchBlt_(hdcWindow, 0, 0, destWidth, destHeight, hdcMem, 0, 0, bmp\bmWidth, bmp\bmHeight, #SRCCOPY)
; Cleans up the memory context
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)
;
; Displays the MetaFile or ENHMetafile or Bitmap or DIB contained in *StgMed
; in the window hWd.
;
; Declare a RECT structure to store the dimensions of the gadget/window
Protected rect.RECT, hdcMem
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
;
; Retrieve the dimensions of the gadget or window
If GetClientRect_(hWd, @rect)
; Calculate the width and height of the gadget or window
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)
; Check if the STGMEDIUM contains a metafile
If *StgMed And *StgMed\tymed = #TYMED_MFPICT
; Lock the memory to access the METAFILEPICT structure
Protected *pMetaFile.METAFILEPICT = GlobalLock_(*StgMed\hMetaFilePict)
If *pMetaFile
; Retrieve the metafile dimensions
If *pMetaFile\hMF
SRatio.f = *pMetaFile\xExt/*pMetaFile\yExt
If SRatio < 1
destWidth = destHeight*SRatio
Else
destHeight = destWidth/SRatio
EndIf
; Set the mapping mode for the device context
SetMapMode_(hdcWindow, #MM_ANISOTROPIC) ; Allows scaling adjustments
SetViewportExtEx_(hdcWindow, destWidth, destHeight, 0)
; Display the metafile content scaled in the window or gadget
PlayMetaFile_(hdcWindow, *pMetaFile\hMF)
EndIf
GlobalUnlock_(*StgMed\hMetaFilePict)
EndIf
ElseIf *StgMed And *StgMed\tymed = #TYMED_ENHMF
If *StgMed\hEnhMetaFile
; Retrieve the Enhanced metafile header and its 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
;
; Set the mapping mode for the device context
Protected DispRect.rect
DispRect\left = 0
DispRect\top = 0
DispRect\right = enhMFHeader\rclbounds\right/XRatio
DispRect\bottom = enhMFHeader\rclbounds\bottom/XRatio
; Display the Enhanced Metafile content scaled in the window or 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
; Lock the memory to access the DIB header
Protected *pDIB = GlobalLock_(*StgMed\hGlobal)
If *pDIB
; Retrieve DIB information
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
; Calculate the ratio to maintain proportions
SRatio.f = pWidth / pHeight
If SRatio < 1
destWidth = destHeight * SRatio
Else
destHeight = destWidth / SRatio
EndIf
;
; Create a memory context to hold the DIB
hdcMem = CreateCompatibleDC_(hdcWindow)
If hdcMem
; Select and display the scaled DIB
StretchDIBits_(hdcWindow, 0, 0, destWidth, destHeight, 0, 0, pWidth, pHeight, *pDIB + headerSize, *pDIB, #DIB_RGB_COLORS, #SRCCOPY)
; Clean up the memory context
DeleteDC_(hdcMem)
EndIf
; Unlock the memory
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) ; limited to 1000 characters.
If CF_Format = #CF_OEMTEXT
*DataBufferTemp = AllocateMemory((Len(Ret$) + 1)*2)
If *DataBufferTemp
; Since we limited the size of the string read to 1000 characters,
; we re-PokeS the truncated string at the starting address
; to ensure that OemToChar does not exceed the size of the buffer
; we allocated for it:
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 : Debug "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
;
Procedure.s ReadFirstBytesFromStorage(*pStorage.IStorage, NumBytes, Canvas = 0)
;
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
;
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 by 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 formats such as 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 any case, 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)
; Clear the gadget used to display images from the IDataObject.
ShowPictFromStgMedium(GadgetID(Canvas1), 0)
EndIf
If Canvas2 And IsGadget(Canvas2)
; Clear the gadget used to display images from the IDataObject.
ShowPictFromStgMedium(GadgetID(Canvas2), 0)
EndIf
If Canvas3 And IsGadget(Canvas3)
; Clear the gadget used to display images from the IDataObject.
ShowPictFromStgMedium(GadgetID(Canvas3), 0)
EndIf
;
Ret$ = "____________________________________________________________" + Chr(13)
;
; Obtain the format enumerator from the 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)
;
; Loop through all available formats
While *enumFormat\Next(1, @formatEtc, #Null) = #S_OK
*pDataObject\getData(formatEtc, @stgm.STGMEDIUM)
Protected Format = WtoUnsignedI(formatEtc\cfFormat)
; Get the format name
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)
;
If Format = #CF_LOCALE Or Format = #CF_OEMTEXT Or Format = #CF_TEXT Or Format = #CF_UNICODETEXT
;
If stgm\tymed = #TYMED_HGLOBAL
;
; Get the handle to global memory
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 language"
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
;
; We don't know what type of data we are dealing with.
; We will still try to read it as if it were characters
; to see what happens:
;
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
;
; Release the enumerator
*enumFormat\Release()
Else
Ret$ = "Error : Unable to open format enumerator."
EndIf
Ret$ + "____________________________________________________________" + Chr(13)
;
If PrintIt
Debug Ret$
EndIf
ProcedureReturn Ret$
EndProcedure
;
Procedure ExamineClipboard()
;
Protected MyWindow, txtrange.CHARRANGE
Protected EGadget, CGadget1, CGadget2, CGadget3, RedoButton, QuitButton
Protected ct, Init, NewDataObject.IDataObject
;
MyWindow = OpenWindow(#PB_Any, 0, 0, 600, 600, "What's in my Clipboard?", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
If MyWindow
;
txtrange.CHARRANGE\cpMin = -1 ; début de la sélection.
txtrange\cpMax = -1 ; fin de la sélection
EGadget = EditorGadget(#PB_Any, 5, 5, WindowWidth(MyWindow)-10, WindowHeight(MyWindow)-240)
SendMessage_(GadgetID(EGadget), #EM_SETTEXTMODE, #TM_RICHTEXT, 0) ; To be able to paste pictures in our EditorGadget
ImageWidth = (WindowWidth(MyWindow)-20)/3
TextGadget(#PB_Any, 5, WindowHeight(MyWindow)-240 + 15, 170, 20, "Pict Metafile/ENHMetafile")
CGadget1 = CanvasGadget(#PB_Any, 5, WindowHeight(MyWindow)-240 + 35, ImageWidth, 175)
;
TextGadget(#PB_Any, ImageWidth + 5 + 5, WindowHeight(MyWindow)-240 + 15, 170, 20, "Bitmap/DIB/DIBV5 Picture")
CGadget2 = CanvasGadget(#PB_Any, ImageWidth + 10, WindowHeight(MyWindow)-240 + 35, ImageWidth, 175)
;
TextGadget(#PB_Any, (ImageWidth + 5)*2 + 5, WindowHeight(MyWindow)-240 + 15, 170, 20, "PNG/JPG/JPEG/TIFF/GIF/ICO")
CGadget3 = CanvasGadget(#PB_Any, (ImageWidth + 5)*2 + 5, WindowHeight(MyWindow)-240 + 35, ImageWidth, 175)
RedoButton = ButtonGadget(#PB_Any, 5, WindowHeight(MyWindow) - 25, 120, 20, "Refresh")
QuitButton = ButtonGadget(#PB_Any, WindowWidth(MyWindow)-125, WindowHeight(MyWindow) - 25, 120, 20, "Quit")
;
SetActiveGadget(EGadget)
;
; We let the entire window draw
; so that our images can be redrawn
; over an existing environment:
For ct = 1 To 100
WindowEvent()
Next
;
Init = 1
;
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_Gadget Or init
EventGadget = EventGadget()
If EventGadget = QuitButton
Event = #PB_Event_CloseWindow
ElseIf EventGadget = RedoButton Or init
If Init = 0 : NewDataObject.IDataObject\Release() : EndIf
OleGetClipboard_(@NewDataObject)
SetGadgetText(EGadget, EnumFormatsFromIDataObject(NewDataObject, 0, CGadget1, CGadget2, CGadget3) + Chr(13) + Chr(13))
SendMessage_(GadgetID(EGadget), #EM_EXSETSEL, 0, @txtrange)
EndIf
EndIf
init = 0
Until Event = #PB_Event_CloseWindow
EndIf
EndProcedure
ExamineClipboard()
