;Rich edit functions. 

;IRichEditOleCallback - place images into an editor gadget. 
;Based on some Powerbasic code found at http://www.hellobasic.com/ by Edwin Knoppert 
;and translated to Purebasic by Stephen Rodriguez. 
;Coded in Purebasic 4. 



#STGM_SHARE_EXCLUSIVE=$00000010 
#STGM_READWRITE = $00000002 
#STGM_CREATE = $00001000 

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) 
;  If RichComObject\Refcount=0 
   AddElement(RichComObject()) 
   RichComObject()\pIntf = ?VTable 
   SendMessage_(hWnd, #EM_SETOLECALLBACK, 0, RichComObject()) 
;  EndIf 
EndProcedure 

Procedure.l RichEdit_QueryInterface(*pObject, REFIID, ppvObj) 
    ProcedureReturn #S_OK 
EndProcedure 

Procedure.l RichEdit_AddRef(*pObject.RichEditOle) 
  *pObject\Refcount+1 
  ProcedureReturn *pObject\Refcount 
EndProcedure 

Procedure.l RichEdit_Release(*pObject.RichEditOle) 
  *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 1 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_ShowContainerUI(*pObject.RichEditOle, fShow) 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_QueryInsertObject(*pObject.RichEditOle, lpclsid, lpstg, cp) 
    ProcedureReturn #S_OK 
EndProcedure 

Procedure.l RichEdit_DeleteObject(*pObject.RichEditOle, lpoleobj) 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_QueryAcceptData(*pObject.RichEditOle, lpdataobj, lpcfFormat, reco, fReally, hMetaPict) 
    ProcedureReturn #S_OK 
EndProcedure 

Procedure.l RichEdit_ContextSensitiveHelp(*pObject.RichEditOle, fEnterMode) 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_GetClipboardData(*pObject.RichEditOle, lpchrg, reco, lplpdataobj) 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_GetDragDropEffect(*pObject.RichEditOle, fDrag, grfKeyState, pdwEffect) 
;PokeL(pdwEffect,0) ;Uncomment this to prevent dropping to the editor gadget. 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 

Procedure.l RichEdit_GetContextMenu(*pObject.RichEditOle, seltype.w, lpoleobj, lpchrg, lphmenu) 
  ProcedureReturn #E_NOTIMPL 
EndProcedure 


;The following function does the main work! 
Procedure.l RichEdit_GetNewStorage(*pObject.RichEditOle, lplpstg) 
  Protected sc, lpLockBytes, t.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. 
    t = lpLockBytes 
    t\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() 
EndDataSection 

; IDE Options = PureBasic v4.02 (Windows - x86)
; CursorPosition = 195
; FirstLine = 28
; Folding = ----