richeditbrowser.pas

Delphi VCL Component Pack

      dvaspect: DWORD;
      dwFlags: DWORD;
      dwUser: DWORD;
   end;

type
   IRichEditOle = interface(IUnknown)['{00020d00-0000-0000-c000-000000000046}']
      function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall;
      function GetObjectCount: HResult; stdcall;
      function GetLinkCount: HResult; stdcall;
      function GetObject(iob: Longint; out reobject: TReObject;
         dwFlags: DWORD): HResult; stdcall;
      function InsertObject(var reobject: TReObject): HResult; stdcall;
      function ConvertObject(iob: Longint; rclsidNew: TIID;
         lpstrUsertypeNew: LPCSTR): HResult; stdcall;
      function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall;
      function SetHostNames(lpstrContainerApp: LPCSTR;
         lpstrContainerObj: LPCSTR): HResult; stdcall;
      function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall;
      function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall;
      function HandsOffStorage(iob: Longint): HResult; stdcall;
      function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall;
      function InPlaceDeactivate: HResult; stdcall;
      function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
      function GetClipboardData(var chrg: TCharRange; reco: DWORD;
         out dataobj: IDataObject): HResult; stdcall;
      function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
         hMetaPict: HGLOBAL): HResult; stdcall;
   end;

   IRichEditOleCallback = interface(IUnknown)
      ['{00020d03-0000-0000-c000-000000000046}']
      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: TCharRange; reco: DWORD;
         out dataobj: IDataObject): HResult; stdcall;
      function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
         var dwEffect: DWORD): HResult; stdcall;
      function GetContextMenu(seltype: Word; const oleobj: IOleObject;
         const chrg: TCharRange; out Menu: HMENU): HResult; stdcall;
   end;

type
   TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
   public
      function QueryInterface(const iid: TGUID; out Obj): HResult; stdcall;
      function _AddRef: Longint; stdcall;
      function _Release: Longint; stdcall;
      function GetNewStorage(out stg: IStorage): HResult; stdcall;
      function GetClipboardData(const chrg: TCharRange; reco: DWORD;
         out dataobj: IDataObject): HResult; stdcall;
      function GetContextMenu(seltype: Word; const oleobj: IOleObject;
         const chrg: TCharRange; out Menu: HMENU): 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 GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
         var dwEffect: DWORD): HResult; stdcall;
   end;

procedure CreateIStorage(out Fstorage: Istorage);
function GetRichOleInterface(ARichEdit: TRichEdit; out RichOleInterface: IRichEditOle; out OleClientSite: IOleclientSite): boolean;
procedure REOleSetCallback(RichEdit: TRichEdit; OleInterface: IRichEditOleCallback);
procedure ReleaseObject(var Obj);
function SetFormatEtc(Cf: TClipFormat; med: Longint; td: PDVTargetDevice = nil;
   Asp: Longint = DVASPECT_CONTENT; li: Longint = -1): TFormatEtc;
function OleSwitchDisplayAspect(OleObject: IOleObject; var CurrentAspect: DWORD;
   NewAspect: DWORD; METAFILEPICT: THandle; DeleteOldAspect, SetUpViewAdvise: boolean;
   AdviseSink: IAdviseSink; var MustUpdate: boolean): HRESULT;
function GetOleClassFile(const Name: string): TCLSID;
function OleCopyPasString(const Source: string; Malloc: IMalloc = nil): POleStr;
function SetStgMedium(Stg, Handle: longint; Release: pointer = nil): TStgMedium;
procedure OleFreeString(Str: POleStr; Malloc: IMalloc = nil);
function OleMalloc(Size: Longword; Malloc: IMalloc = nil): pointer;
procedure OleFree(Mem: pointer; Malloc: IMalloc = nil);
procedure ChangeOleIcon(REdit: TRichEdit; HIcon: Hwnd; LabelIcon: string);

var
   MyCallback: TRichEditOleCallback;
   FRichEditModule: THandle;
   RichEditOle: IRichEditOle;
   RichEditOleCallback: IRichEditOleCallback;
 // RichEditVersion     : TRichEditVersion;

implementation

uses StdCtrls, dialogs, Forms, Printers, sysUtils, ShellAPI, JPEG;

resourcestring
   sSaveChanges = 'Save changes to %s?';
   sOverWrite = 'The file already exist. Do you want to overwrite %s ?';
   sUntitled = 'Untitled';
   sModified = 'Modified';
   sColRowInfo = 'Line: %3d   Col: %3d';

type
   TImageDataObject = class(TInterfacedObject, IDataObject)
   private
      FMedium: STGMEDIUM;
      FFormat: FORMATETC;
      FHasData: Boolean;
   protected
      function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
      function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
      function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
      function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall;
      function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall;
      function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
      function DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
      function DUnadvise(dwConnection: Longint): HResult; stdcall;
      function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
      procedure SetBitmap(const ASource: TBitmap);
      function GetOleObject(const AClient: IOleClientSite;
         const AStorage: IStorage): IOleObject;
   public
      class procedure InsertBitmap(ADest: TCustomRichEdit; ASource: TBitmap);
      destructor Destroy(); override;
   end;

class procedure TImageDataObject.InsertBitmap;
var
   idoImage: TImageDataObject;
   ifOLE: IRichEditOle;
   ifData: IDataObject;
   ifClient: IOleClientSite;
   ifStorage: IStorage;
   ifBytes: ILockBytes;
   ifOLEObject: IOleObject;
   sCode: HRESULT;
   reObj: TREObject;
   gdClass: TGUID;
begin
   ifOLE := nil;
   SendMessage(ADest.Handle, EM_GETOLEINTERFACE, 0, LPARAM(@ifOLE));
   if Assigned(ifOLE) then
      try
         idoImage := TImageDataObject.Create();
         if idoImage.GetInterface(IDataObject, ifData) then
            try
               idoImage.SetBitmap(ASource);
               ifClient := nil;
               ifOLE.GetClientSite(ifClient);
               if Assigned(ifClient) then
                  try
                     ifBytes := nil;
                     sCode := CreateILockBytesOnHGlobal(0, True, ifBytes);
                     if (sCode = S_OK) and (Assigned(ifBytes)) then
                        try
                           sCode := StgCreateDocfileOnILockBytes(ifBytes, STGM_SHARE_EXCLUSIVE or
                              STGM_CREATE or STGM_READWRITE, 0, ifStorage);
                           if sCode = S_OK then
                              try
                                 ifOLEObject := idoImage.GetOleObject(ifClient, ifStorage);
                                 if Assigned(ifOLEObject) then
                                    try
                                       OleSetContainedObject(ifOLEObject, True);
                                       sCode := ifOLEObject.GetUserClassID(gdClass);
                                       if sCode = S_OK then
                                          begin
                                             with reObj do
                                                begin
                              //clsid       := '';
                                                   cp := LongInt(REO_CP_SELECTION);
                                                   dvaspect := DVASPECT_CONTENT;
                                                   oleobj := ifOLEObject;
                                                   olesite := ifClient;
                                                   stg := ifStorage;
                                                end;
                                             ifOLE.InsertObject(reObj);
                                          end;
                                    finally
                                       ifOLEObject := nil;
                                    end;
                              finally
                                 ifStorage := nil;
                              end;
                        finally
                           ifBytes := nil;
                        end;
                  finally
                     ifClient := nil;
                  end;
            finally
               ifData := nil;
            end;
      finally
         ifOLE := nil;
      end;
end;

procedure TImageDataObject.SetBitmap;
begin
   FMedium.tymed := TYMED_GDI;
   FMedium.hBitmap := ASource.Handle;
   FMedium.unkForRelease := nil;
   FFormat.cfFormat := CF_BITMAP;
   FFormat.ptd := nil;
   FFormat.dwAspect := DVASPECT_CONTENT;
   FFormat.lindex := -1;
   FFormat.tymed := TYMED_GDI;
end;

function TImageDataObject.GetOleObject;
var
   sCode: HRESULT;
begin
   sCode := OleCreateStaticFromData(Self, IOleObject, OLERendER_FORMAT,
      @FFormat, AClient, AStorage, Result);
   if sCode <> S_OK then
      begin
         OleCheck(sCode);
         Result := nil;
      end;
end;

destructor TImageDataObject.Destroy;
begin
   if FHasData then
      ReleaseStgMedium(FMedium);
   inherited;
end;

function TImageDataObject.GetData;
var
   hDest: THandle;

begin
   hDest := OleDuplicateData(FMedium.hBitmap, CF_BITMAP, 0);
   if (hDest <> 0) then
      begin
         medium.tymed := TYMED_GDI;
         medium.hBitmap := hDest;
         medium.unkForRelease := nil;
         Result := S_OK;
      end
   else
      Result := E_HANDLE;
end;

function TImageDataObject.GetDataHere;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.QueryGetData;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.GetCanonicalFormatEtc;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.SetData;
begin
   FMedium := medium;
   FFormat := formatetc;
   FHasData := True;
   Result := S_OK;
end;

function TImageDataObject.EnumFormatEtc;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.DAdvise;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.DUnadvise;
begin
   Result := E_NOTIMPL;
end;

function TImageDataObject.EnumDAdvise;
begin
   Result := E_NOTIMPL;
end;

function TRichEditOleCallback.QueryInterface(const iid: TGUID; out Obj): HResult;
begin
   if GetInterface(iid, Obj) then
      Result := S_OK
   else
      Result := E_NOINTERFACE;
end;

function TRichEditOleCallback._AddRef: LongInt;
begin
   Inc(FRefCount);
   Result := FRefCount;
end;

function TRichEditOleCallback._Release: LongInt;
begin
   Dec(FRefCount);
   Result := FRefCount;
end;

function TRichEditOleCallback.GetNewStorage(out stg: IStorage): HResult;
begin
   try
      CreateIStorage(stg);
      Result := S_OK;
   except
      Result := E_OUTOFMEMORY;
   end;
end;

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

function TRichEditOleCallback.GetContextMenu(seltype: Word;
   const oleobj: IOleObject; const chrg: TCharRange;
   out Menu: HMENU): HResult;
begin
 // menu:=0;
   Result := S_OK; // Result := E_NOTIMPL;
end;

function TRichEditOleCallback.GetInPlaceContext(out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow; lpFrameInfo: POleInPlaceFrameInfo): HResult;
begin
   Result := S_OK;
end;

function TRichEditOleCallback.QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
   cp: Longint): HResult;
begin
   Result := NOERROR;
end;

function TRichEditOleCallback.DeleteObject(const oleobj: IOleObject): HResult;
begin
   if Assigned(oleobj) then
      oleobj.Close(OLECLOSE_NOSAVE);
   Result := NOERROR;
end;

function TRichEditOleCallback.QueryAcceptData(const dataobj: IDataObject;
   var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
   hMetaPict: HGLOBAL): HResult;
begin
   Result := S_OK;
end;

function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
begin
   Result := NOERROR;
end;

function TRichEditOleCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
   var dwEffect: DWORD): HResult;
begin
   Result := E_NOTIMPL;
end;

function TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HResult;
begin
   Result := S_OK;
end;

procedure CreateIStorage(out Fstorage: Istorage);
var
   FlockBytes: IlockBytes;
begin
   OleCheck(CreateILockBytesOnHGlobal(0, True, FLockBytes));
   OleCheck(StgCreateDocfileOnILockBytes(FLockBytes, STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, FStorage))
end;

function GetRichOleInterface(ARichEdit: TRichEdit; out RichOleInterface: IRichEditOle; out OleClientSite: IOleclientSite): boolean;
var
   AppName: string;
begin
   Result := False;
   if boolean(SendMessage(ARichEdit.Handle, EM_GETOLEINTERFACE, 0, longint(@RichOleInterface))) then
      begin