lazarus-ccr/components/richmemo/win32/win32richmemoole.pas

{
 Win32RichMemoOle.pas

 Author: Dmitry 'skalogryz' Boyarintsev

 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************
}
unit Win32RichMemoOle;

interface

uses
  Windows, ActiveX, ComObj, Win32RichMemoProc, RichEdit;

{.$define oledebug}

type

  { TCustomObject }

  TCustomObject = class(TInterfacedObject, IOleObject)
  protected
    fSink : IAdviseSink;
    function SetClientSite(const clientSite: IOleClientSite): HResult;StdCall;
    function GetClientSite(out clientSite: IOleClientSite): HResult;StdCall;
    function SetHostNames(szContainerApp: POleStr; szContainerObj: POleStr): HResult;StdCall;
    function Close(dwSaveOption: DWORD): HResult;StdCall;
    function SetMoniker(dwWhichMoniker: DWORD; const mk: IMoniker): HResult;StdCall;
    function GetMoniker(dwAssign: DWORD; dwWhichMoniker: DWORD; out mk: IMoniker): HResult;StdCall;
    function InitFromData(const dataObject: IDataObject; fCreation: BOOL; dwReserved: DWORD): HResult;StdCall;
    function GetClipboardData({%H-}dwReserved: DWORD; out {%H-}dataObject: IDataObject): HResult;StdCall;
    function DoVerb(iVerb: LONG; msg: PMsg; const activeSite: IOleClientSite; lindex: LONG; hwndParent: HWND; const posRect: TRect): HResult;StdCall;
    function EnumVerbs(out {%H-}enumOleVerb: IEnumOleVerb): HResult;StdCall;
    function Update: HResult;StdCall;
    function IsUpToDate: HResult;StdCall;
    function GetUserClassID(out clsid: TCLSID): HResult;StdCall;
    function GetUserType(dwFormOfType: DWORD; out pszUserType: POleStr): HResult;StdCall;
    function SetExtent(dwDrawAspect: DWORD; const size: TPoint): HResult;StdCall;
    function GetExtent(dwDrawAspect: DWORD; out size: TPoint): HResult;StdCall;
    function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;StdCall;
    function Unadvise(dwConnection: DWORD): HResult;StdCall;
    function EnumAdvise(out aenumAdvise: IEnumStatData): HResult;StdCall;
    function GetMiscStatus(dwAspect: DWORD; out dwStatus: DWORD): HResult;StdCall;
    function SetColorScheme(const logpal: TLogPalette): HResult;StdCall;
  end;

  { TCustomDataObject }

  TCustomDataObject = class(TCustomObject, IOleObject, IDataObject)
    Function GetData(Const formatetcIn : FORMATETC;Out medium : STGMEDIUM):HRESULT; STDCALL;
    Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL;
    Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL;
    Function GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl;
    Function SetData (Const pformatetc : FORMATETC;const medium:STGMEDIUM;FRelease : BOOL):HRESULT; StdCall;
    Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall;
    Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall;
    Function DUnadvise(dwconnection :DWord) :HRESULT;StdCall;
    Function EnumDAdvise(Out aenumAdvise : IEnumStatData):HResult;StdCall;
  end;

  { TCustomDataViewObject }

  TCustomDataViewObject = class(TCustomDataObject, IOleObject, IDataObject, IViewObject)
    function Draw(dwDrawAspect:DWord;LIndex:Long;pvaspect:pointer;ptd:PDVTARGETDEVICE;hdcTargetDev:HDC; hdcDraw:HDC;lprcBounds:PRECTL;lprcWBounds:PRECTL;pfncontinue:TContinueCallback;dwcontinue:ULONG_PTR):HResult; stdcall;
    function GetColorSet(wDrawAspect:DWord;LIndex:Long;pvaspect:pointer;ptd:PDVTARGETDEVICE;hdcTargetDev:HDC;var ppcolorset:PLogPalette):HREsult; stdcall;
    function Freeze(dwDrawAspect:DWord;LIndex:Long;pvaspect:pointer;pdwfreeze:pdword):HResult;stdcall;
    function Unfreeze(dwfreeze:dword):HResult; stdcall;
    function SetAdvise(aspects:DWORD;advf:DWORD;padvSink:IAdviseSink):HRESULT;stdcall;
    function Getadvise(paspects:pdword;padvf:pdword;out ppadvsink: IADviseSink):HRESULT;stdcall;
  end;

  { TRichEditCallback }

  TRichEditCallback = class(TInterfacedObject, IRichEditOleCallback)
    function GetNewStorage(out stg: IStorage): HRESULT; stdcall;
    function GetInPlaceContext(out Frame: IOleInPlaceFrame;
      out Doc: IOleInPlaceUIWindow;
      lpFrameInfo: POleInPlaceFrameInfo): HRESULT; stdcall;
    function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;
    function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
      cp: LongInt): HRESULT; stdcall;
    function DeleteObject(const oleobj: IOleObject): HRESULT; stdcall;
    function QueryAcceptData(const dataobj: IDataObject;
      var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
      hMetaPict: HGLOBAL): HRESULT; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
    function GetClipboardData(const chrg: RichEdit.TCharRange; reco: DWORD;
      out dataobj: IDataObject): HRESULT; stdcall;
    function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
      var dwEffect: DWORD): HRESULT; stdcall;
    function GetContextMenu(seltype: Word; oleobj: IOleObject;
      const chrg: TCharRange; var menu: HMENU): HRESULT; stdcall;
  end;


implementation

{ TRichEditCallback }

function TRichEditCallback.GetNewStorage(out stg: IStorage): HRESULT; stdcall;
begin
  StgCreateDocfile(nil, STGM_READWRITE or STGM_SHARE_EXCLUSIVE, 0,stg);
  Result := S_OK;
end;

function TRichEditCallback.GetInPlaceContext(out Frame: IOleInPlaceFrame; out
  Doc: IOleInPlaceUIWindow; lpFrameInfo: POleInPlaceFrameInfo): HRESULT;
  stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.ShowContainerUI(fShow: BOOL): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.QueryInsertObject(const clsid: TCLSID;
  const stg: IStorage; cp: LongInt): HRESULT; stdcall;
begin
  Result := S_OK;
end;

function TRichEditCallback.DeleteObject(const oleobj: IOleObject): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.QueryAcceptData(const dataobj: IDataObject;
  var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL
  ): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.GetClipboardData(const chrg: TCharRange; reco: DWORD; out
  dataobj: IDataObject): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
  var dwEffect: DWORD): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TRichEditCallback.GetContextMenu(seltype: Word; oleobj: IOleObject;
  const chrg: TCharRange; var menu: HMENU): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

{ TCustomObject }

function TCustomObject.SetClientSite(const clientSite: IOleClientSite
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.SetClientSide');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetClientSite(out clientSite: IOleClientSite): HResult;
  StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetClientSite');{$endif}
  Result:=S_OK;
end;

function TCustomObject.SetHostNames(szContainerApp: POleStr;
  szContainerObj: POleStr): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.SetHostNames');{$endif}
  Result:=S_OK;
end;

function TCustomObject.Close(dwSaveOption: DWORD): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.Close');{$endif}
  Result:=S_OK;
end;

function TCustomObject.SetMoniker(dwWhichMoniker: DWORD; const mk: IMoniker
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.SetMoniker');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetMoniker(dwAssign: DWORD; dwWhichMoniker: DWORD; out
  mk: IMoniker): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetMoniker');{$endif}
  Result:=E_NOTIMPL;
end;

function TCustomObject.InitFromData(const dataObject: IDataObject;
  fCreation: BOOL; dwReserved: DWORD): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.InitFromData');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetClipboardData(dwReserved: DWORD; out
  dataObject: IDataObject): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetClipboardData');{$endif}
  Result:=E_NOTIMPL;
end;

function TCustomObject.DoVerb(iVerb: LONG; msg: PMsg;
  const activeSite: IOleClientSite; lindex: LONG; hwndParent: HWND;
  const posRect: TRect): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.DoVerb');{$endif}
  Result:=S_OK;
end;

function TCustomObject.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult;
  StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.EnumVerbs');{$endif}
  Result:=S_OK;
end;

function TCustomObject.Update: HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.Update');{$endif}
  Result:=S_OK;
end;

function TCustomObject.IsUpToDate: HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.IsUpToDate');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetUserClassID(out clsid: TCLSID): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetUserClassID');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetUserType(dwFormOfType: DWORD; out pszUserType: POleStr
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetUserType');{$endif}
  Result:=S_OK;
end;

function TCustomObject.SetExtent(dwDrawAspect: DWORD; const size: TPoint
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.SetExtent');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetExtent(dwDrawAspect: DWORD; out size: TPoint
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetExtent');{$endif}
  Result:=S_OK;
end;

function TCustomObject.Advise(const advSink: IAdviseSink; out
  dwConnection: Longint): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.Advise');{$endif}
  fSink := advSink;
  dwConnection:=1;
  Result:=S_OK;
end;

function TCustomObject.Unadvise(dwConnection: DWORD): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.Unadvise');{$endif}
  fSink:=nil;
  Result:=S_OK;
end;

function TCustomObject.EnumAdvise(out aenumAdvise: IEnumStatData): HResult;
  StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.EnumAdvise');{$endif}
  Result:=S_OK;
end;

function TCustomObject.GetMiscStatus(dwAspect: DWORD; out dwStatus: DWORD
  ): HResult; StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.GetMiscStatus');{$endif}
  Result:=S_OK;
end;

function TCustomObject.SetColorScheme(const logpal: TLogPalette): HResult;
  StdCall;
begin
  {$ifdef oledebug}writeln('IOleObject.SetColorScheme');{$endif}
  Result:=S_OK;
end;

{ TCustomDataObject }

function TCustomDataObject.GetData(const formatetcIn: FORMATETC; out
  medium: STGMEDIUM): HRESULT; STDCALL;
begin
  {$ifdef oledebug}writeln('IDataObject.getData');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.GetDataHere(const pformatetc: FormatETC; out
  medium: STGMEDIUM): HRESULT; STDCALL;
begin
  {$ifdef oledebug}writeln('IDataObject.GetDataHere');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.QueryGetData(const pformatetc: FORMATETC): HRESULT;
  STDCALL;
begin
  {$ifdef oledebug}writeln('IDataObject.QueryGetData');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.GetCanonicalFormatEtc(const pformatetcIn: FORMATETC;
  out pformatetcOut: FORMATETC): HResult; STDCALl;
begin
  {$ifdef oledebug}writeln('IDataObject.GetCanonicalFormatEtc');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.SetData(const pformatetc: FORMATETC;
  const medium: STGMEDIUM; FRelease: BOOL): HRESULT; StdCall;
begin
  {$ifdef oledebug}writeln('IDataObject.SetData');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.EnumFormatEtc(dwDirection: DWord; out
  enumformatetcpara: IENUMFORMATETC): HRESULT; StdCall;
begin
  {$ifdef oledebug}writeln('IDataObject.EnumFormatEtc');{$endif}
  Result:=E_NOTIMPL;
end;

function TCustomDataObject.DAdvise(const formatetc: FORMATETC; advf: DWORD;
  const AdvSink: IAdviseSink; out dwConnection: DWORD): HRESULT; StdCall;
begin
  {$ifdef oledebug}writeln('IDataObject.DAdvise');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.DUnadvise(dwconnection: DWord): HRESULT; StdCall;
begin
  {$ifdef oledebug}writeln('IDataObject.DUnadvise');{$endif}
  Result:=S_OK;
end;

function TCustomDataObject.EnumDAdvise(out aenumAdvise: IEnumStatData): HResult;
  StdCall;
begin
  {$ifdef oledebug}writeln('IDataObject.EnumDAdvise');{$endif}
  Result:=S_OK;
end;


{ TCustomDataViewObject }

function TCustomDataViewObject.Draw(dwDrawAspect: DWord; LIndex: Long;
  pvaspect: pointer; ptd: PDVTARGETDEVICE; hdcTargetDev: HDC; hdcDraw: HDC;
  lprcBounds: PRECTL; lprcWBounds: PRECTL; pfncontinue: TContinueCallback;
  dwcontinue: ULONG_PTR): HResult; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.Draw');{$endif}
  Result:=S_OK;
end;

function TCustomDataViewObject.GetColorSet(wDrawAspect: DWord; LIndex: Long;
  pvaspect: pointer; ptd: PDVTARGETDEVICE; hdcTargetDev: HDC;
  var ppcolorset: PLogPalette): HREsult; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.GetColorSet');{$endif}
  Result:=S_OK;
end;

function TCustomDataViewObject.Freeze(dwDrawAspect: DWord; LIndex: Long;
  pvaspect: pointer; pdwfreeze: pdword): HResult; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.Freeze');{$endif}
  Result:=S_OK;
end;

function TCustomDataViewObject.Unfreeze(dwfreeze: dword): HResult; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.Unfreeze');{$endif}
  Result:=S_OK;
end;

function TCustomDataViewObject.SetAdvise(aspects: DWORD; advf: DWORD;
  padvSink: IAdviseSink): HRESULT; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.SetAdvise');{$endif}
  Result:=S_OK;
end;

function TCustomDataViewObject.Getadvise(paspects: pdword; padvf: pdword; out
  ppadvsink: IADviseSink): HRESULT; stdcall;
begin
  {$ifdef oledebug}writeln('IDataView.Getadvise');{$endif}
  Result:=S_OK;
end;

end.