Un exemple avec le source du chargement d'un fichier Bitmap avec le code source de Srod qui permet de sauvegarder et charger un fichier rtf avec des images et de déplacer une image à l'intérieur de l'éditeur.
Code : Tout sélectionner
; Insérer une image Bitmap dans un éditeur à partir d'un fichier
; Version PureBasic 4.10
#STGM_SHARE_EXCLUSIVE=$00000010
#STGM_READWRITE = $00000002
#STGM_CREATE = $00001000
#REO_CP_SELECTION=$FFFFFFFF
#REO_RESIZABLE=1
#REO_BELOWBASELINE=2
#OLERENDER_DRAW=1
Global RichEditOleObject.IRichEditOle
Global lpStorage.IStorage,lpObject.IOleObject,lpClientSite.IOleClientSite
Prototype.l CreateFromFile(a.l, FileName.p-bstr, b.l, c.l, d.l, e.l, f.l, g.l)
Declare.l StreamDataCallback(dwCookie, pbBuff, cb, pcb)
Declare.l StreamFileInCallback(dwCookie, pbBuff, cb, pcb)
Declare.l StreamFileOutCallback(dwCookie, pbBuff, cb, pcb)
Structure RichEditOle
*pIntf.l
Refcount.l
EndStructure
;The following variable forms the IRichEditOleCallback interface for a rich edit control.
Global NewList RichComObject.RichEditOle()
;The following variable points to the rtf stream when including rtf files.
Global prtf
;-*****USER FUNCTIONS***************************************************************************
;***********************************************************************************************
;The following procedure includes an rtf file from a memory stream.
;Include the file using Include Binary etc.
;Returns zero if no error encountered.
;***********************************************************************************************
Procedure.l CatchRTF(gadget, datastart, dataend, replaceall=0)
Protected edstr.EDITSTREAM
prtf = datastart
edstr\dwCookie = dataend
edstr\dwError = 0
edstr\pfnCallback = @StreamDataCallback()
SendMessage_(GadgetID(gadget), #EM_STREAMIN, #SF_RTF|replaceall, edstr)
ProcedureReturn edstr\dwError
EndProcedure
;The following is called repeatedly by Windows to stream data into an editor gadget.
Procedure.l StreamDataCallback(dwCookie, pbBuff, cb, pcb)
Protected Result
Result = 0
If prtf>=dwCookie
cb = 0
Result = 1
ElseIf prtf+cb>=dwCookie
cb = dwCookie-prtf
EndIf
CopyMemory(prtf, pbBuff, cb)
prtf+cb
PokeL(pcb, cb)
ProcedureReturn Result
EndProcedure
;***********************************************************************************************
;The following procedure loads an rtf file into an editor gadget.
;Returns zero if no error encountered.
;***********************************************************************************************
Procedure.l LoadRTF(gadget, FileName.s, replaceall=0)
Protected edstr.EDITSTREAM
edstr\dwCookie = ReadFile(#PB_Any, FileName)
If edstr\dwCookie
edstr\dwError = 0
edstr\pfnCallback = @StreamFileInCallback()
SendMessage_(GadgetID(gadget), #EM_STREAMIN, #SF_RTF|replaceall, edstr)
CloseFile(edstr\dwCookie)
ProcedureReturn edstr\dwError
Else
ProcedureReturn 1
EndIf
EndProcedure
;The following is called repeatedly by Windows to stream data into an editor gadget from an external file.
Procedure.l StreamFileInCallback(dwCookie, pbBuff, cb, pcb)
Protected Result, length
Result=0
length=ReadData(dwCookie, pbBuff, cb)
PokeL(pcb, length)
If length = 0
Result = 1
EndIf
ProcedureReturn Result
EndProcedure
;***********************************************************************************************
;The following procedure saves the rtf content of an editor gadget to an external file.
;Returns zero if no error encountered.
;***********************************************************************************************
Procedure.l SaveRTF(gadget, FileName.s)
Protected edstr.EDITSTREAM
edstr\dwCookie = CreateFile(#PB_Any, FileName)
If edstr\dwCookie
edstr\dwError = 0
edstr\pfnCallback = @StreamFileOutCallback()
SendMessage_(GadgetID(gadget), #EM_STREAMOUT, #SF_RTF, edstr)
CloseFile(edstr\dwCookie)
ProcedureReturn edstr\dwError
Else
ProcedureReturn 1
EndIf
EndProcedure
;The following is called repeatedly by Windows to stream data from an editor gadget to an external file.
Procedure.l StreamFileOutCallback(dwCookie, pbBuff, cb, pcb)
Protected Result, length
Result=0
WriteData(dwCookie, pbBuff, cb)
PokeL(pcb, cb)
If cb = 0
Result = 1
EndIf
ProcedureReturn Result
EndProcedure
;***********************************************************************************************
;Implementation procedures for OLE. Most are not actually used but are still needed.
;***********************************************************************************************
;***********************************************************************************************
;Set up the com interface for our rich edit control.
;***********************************************************************************************
Procedure.l RichEdit_SetInterface(hwnd)
Debug 1
; If RichComObject\Refcount=0
AddElement(RichComObject())
RichComObject()\pIntf = ?VTable
SendMessage_(hwnd, #EM_SETOLECALLBACK, 0, RichComObject())
; EndIf
EndProcedure
Procedure.l RichEdit_QueryInterface(*pObject.RichEditOle, REFIID, ppvObj)
Debug 2
ppvObj=0
If CompareMemory(REFIID,?IID_IRichEditOleCallback,16)
ppvObj=*pObject\pIntf
ProcedureReturn #S_OK
Else
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure.l RichEdit_AddRef(*pObject.RichEditOle)
Debug 3
*pObject\Refcount+1
ProcedureReturn *pObject\Refcount
EndProcedure
Procedure.l RichEdit_Release(*pObject.RichEditOle)
Debug 4
*pObject\Refcount-1
If *pObject\Refcount > 0
ProcedureReturn *pObject\Refcount
Else
;Remove entry in the linked list.
ForEach RichComObject()
If RichComObject()=*pObject
DeleteElement(RichComObject()) : Break
EndIf
Next
*pObject=0
EndIf
EndProcedure
Procedure.l RichEdit_GetInPlaceContext(*pObject.RichEditOle, lplpFrame, lplpDoc, lpFrameInfo)
Debug 5
Debug 1
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_ShowContainerUI(*pObject.RichEditOle, fShow)
Debug 6
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_QueryInsertObject(*pObject.RichEditOle, lpclsid, lpstg, cp)
Debug 7
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_DeleteObject(*pObject.RichEditOle, lpoleobj)
Debug 8
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_QueryAcceptData(*pObject.RichEditOle, lpdataobj, lpcfFormat, reco, fReally, hMetaPict)
Debug 9
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_ContextSensitiveHelp(*pObject.RichEditOle, fEnterMode)
Debug 10
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_GetClipboardData(*pObject.RichEditOle, lpchrg, reco, lplpdataobj)
Debug 11
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_GetDragDropEffect(*pObject.RichEditOle, fDrag, grfKeyState, pdwEffect)
Debug 12
;If fDrag=0
;PokeL(pdwEffect,0) ;Uncomment this to prevent dropping to the editor gadget.
ProcedureReturn #S_OK
EndProcedure
Procedure.l RichEdit_GetContextMenu(*pObject.RichEditOle, seltype.w, lpoleobj, lpchrg, lphmenu)
Debug 13
ProcedureReturn #S_OK
EndProcedure
;The following function does the main work!
Procedure.l RichEdit_GetNewStorage(*pObject.RichEditOle, lplpstg)
Debug 14
Protected sc, lpLockBytes.ILockBytes
;Attempt to create a byte array object which acts as the 'foundation' for the upcoming compound file.
sc=CreateILockBytesOnHGlobal_(#Null, #True, @lpLockBytes)
If sc ;This means that the allocation failed.
ProcedureReturn sc
EndIf
;Allocation succeeded so we now attempt to create a compound file storage object.
sc=StgCreateDocfileOnILockBytes_(lpLockBytes, #STGM_SHARE_EXCLUSIVE|#STGM_READWRITE|#STGM_CREATE, 0, lplpstg)
If sc ;This means that the allocation failed.
lpLockBytes\Release()
ProcedureReturn sc
EndIf
EndProcedure
;***********************************************************************************************
DataSection
VTable:
Data.l @RichEdit_QueryInterface(), @RichEdit_AddRef(), @RichEdit_Release(), @RichEdit_GetNewStorage()
Data.l @RichEdit_GetInPlaceContext(), @RichEdit_ShowContainerUI(), @RichEdit_QueryInsertObject()
Data.l @RichEdit_DeleteObject(), @RichEdit_QueryAcceptData(), @RichEdit_ContextSensitiveHelp(), @RichEdit_GetClipboardData()
Data.l @RichEdit_GetDragDropEffect(), @RichEdit_GetContextMenu()
IID_IRichEditOle: ;"0x00020D00, 0, 0, 0xC0,0,0,0,0,0,0,0x46)"
Data.l $00020D00
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IRichEditOleCallback: ;" 0x00020D03, 0, 0, 0xC0,0,0,0,0,0,0,0x46"
Data.l $00020D03
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
EndDataSection
Procedure.l FileToOLE(FileName.s,Rich_Edit_ID.l)
SendMessage_(GadgetID(Rich_Edit_ID), #EM_GETOLEINTERFACE, 0, @RichEditOleObject.IRichEditOle)
If RichEditOleObject
lpLockBytes.ILockBytes
cfFormat = 0
lpFormatEtc.FORMATETC
clsid.CLSID
CopyMemory(?IID_NULL,@clsid,16)
sc = CreateILockBytesOnHGlobal_(#Null, #True, @lpLockBytes)
If sc = #S_OK
sc =StgCreateDocfileOnILockBytes_(lpLockBytes,#STGM_SHARE_EXCLUSIVE|#STGM_CREATE|#STGM_READWRITE, 0, @lpStorage)
If sc = #S_OK
lpLockBytes\Release()
Else
ProcedureReturn #False
EndIf
Else
ProcedureReturn #False
EndIf
;// fill in FORMATETC struct
lpFormatEtc\cfFormat = 0
lpFormatEtc\ptd = #Null
lpFormatEtc\dwAspect = #DVASPECT_CONTENT
lpFormatEtc\lindex = -1
lpFormatEtc\tymed = #TYMED_NULL
;// attempt To create the object
RichEditOleObject\GetClientSite(@lpClientSite)
If OpenLibrary(0, "ole32.dll")
CreateFromFile.CreateFromFile = GetFunction(0, "OleCreateFromFile")
sc = CreateFromFile( clsid, FileName, ?IID_IUnknown, #OLERENDER_DRAW, lpFormatEtc, lpClientSite, lpStorage, @lpObject)
CloseLibrary(0)
EndIf
Debug sc
; je devrais avoir 0 mais on a 48 ?
;// lpObject is currently an IUnknown, convert To IOleObject
If lpObject<> #Null
lpUnk.IUnknown = lpObject
lpUnk\QueryInterface(?IID_IOleObject, @lpObject)
lpUnk\Release()
EndIf
;// all items are "contained" -- this makes our reference To this object
;// weak -- which is needed For links To embedding silent update.
OleSetContainedObject_(lpObject, #True)
reobject.REOBJECT
ZeroMemory_(@reobject, SizeOf(REOBJECT))
reobject\cbStruct = SizeOf(REOBJECT)
sc = lpObject\GetUserClassID(clsid.CLSID)
Debug sc
CopyMemory(@clsid,@reobject\clsid,16)
reobject\cp = #REO_CP_SELECTION
reobject\dvaspect = #DVASPECT_CONTENT
reobject\dwFlags = #REO_RESIZABLE | #REO_BELOWBASELINE
reobject\dwUser = 0
reobject\poleobj = lpObject
reobject\polesite = lpClientSite
reobject\pstg = lpStorage
reobject\sizel\cx=0
reobject\sizel\cy=0
RichEditOleObject\InsertObject(reobject)
If lpObject
lpObject\Release()
lpObject = #Null
EndIf
If lpStorage
lpStorage\Release()
lpStorage = #Null
EndIf
If lpClientSite
lpClientSite\Release()
lpClientSite = #Null
EndIf
If RichEditOleObject
RichEditOleObject\Release()
RichEditOleObject = #Null
EndIf
ProcedureReturn #True
EndIf
EndProcedure
Enumeration
#GADGET_Editor
EndEnumeration
If OpenWindow(0, 0, 0, 500, 440, "RichEdit", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
CreateGadgetList(WindowID(0))
EditorGadget(#GADGET_Editor, 10, 10, 480, 380)
RichEdit_SetInterface(GadgetID(#GADGET_Editor))
ButtonGadget(1, 10, 400, 120, 20, "Ouvrir un fichier Image")
ButtonGadget(2, 140, 400, 120, 20, "Sauver le Fichier")
ButtonGadget(3, 280, 400, 120, 20, "Ouvrir un Fichier")
Repeat
Event = WaitWindowEvent()
Select Event
Case #PB_Event_Gadget
Select EventGadget()
Case 1
Select EventType()
Case #PB_EventType_LeftClick
FichierParDefaut$ = "C:\"
Filtre$ = "Bitmap(*.bmp)|*.bmp"
Filtre = 0
Fichier$ = OpenFileRequester("Choisissez un fichier à charger", FichierParDefaut$, Filtre$, Filtre)
If Fichier$
Ret=FileToOLE(Fichier$,#GADGET_Editor)
If Ret=0
MessageRequester("Information", "Le chargement de l'image dans l'éditeur à échoué", 0)
EndIf
Else
MessageRequester("Information", "La sélection a été annulée.", 0)
EndIf
EndSelect
Case 2
Select EventType()
Case #PB_EventType_LeftClick
FichierParDefaut$ = "C:\"
Filtre$ = "Fichier texte(*.rtf)|*.rtf"
Filtre = 0
Fichier$ = SaveFileRequester("Choisissez un fichier à sauvegarder", FichierParDefaut$, Filtre$, Filtre)
If Fichier$
SaveRTF(#GADGET_Editor,Fichier$)
Else
MessageRequester("Information", "La sélection a été annulée.", 0)
EndIf
EndSelect
Case 3
Select EventType()
Case #PB_EventType_LeftClick
FichierParDefaut$ = "C:\"
Filtre$ = "Fichier texte(*.rtf)|*.rtf"
Filtre = 0
Fichier$ = OpenFileRequester("Choisissez un fichier à charger", FichierParDefaut$, Filtre$, Filtre)
If Fichier$
LoadRTF(#GADGET_Editor, "c:\essai.rtf")
Else
MessageRequester("Information", "La sélection a été annulée.", 0)
EndIf
EndSelect
EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow
EndIf
End
DataSection
IID_IOleObject: ;"{00000112-0000-0000-C000-000000000046}"
Data.l $00000112
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IUnknown: ;"{00000000-0000-0000-C000-000000000046}"
Data.l $00000000
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_NULL: ;"{00000000-0000-0000-0000-000000000000}"
Data.l $00000000
Data.w $0000,$0000
Data.b $00,$00,$00,$00,$00,$00,$00,$00
EndDataSection
)
