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
