An example avec the code of Srod for load and save a file with image and move the image inside the editor!
Code: Select all
; 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, "Save the file")
ButtonGadget(3, 280, 400, 120, 20, "Open a file")
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
