richeditbrowser.pas

Delphi VCL Component Pack

         try
            AppName := Application.Title;
            if Trim(AppName) = '' then
               AppName := ExtractFileName(Application.ExeName);
            RichOleInterface.SetHostNames(PChar(AppName), PChar(AppName));
            RichOleInterface.GetClientSite(OleclientSite);
            Result := True;
         except
            Result := False;
         end;
      end;
end;

procedure REOleSetCallback(RichEdit: TRichEdit; OleInterface: IRichEditOleCallback);
begin
   SendMessage(RichEdit.Handle, EM_SETOLECALLBACK, 0, LPARAM(Oleinterface));
end;

procedure ReleaseObject(var Obj);
begin
   if IUnknown(Obj) <> nil then
      begin
         IUnknown(Obj)._Release;
         IUnknown(Obj) := nil;
      end;
end;

function SetFormatEtc(Cf: TClipFormat; med: Longint; td: PDVTargetDevice = nil;
   Asp: Longint = DVASPECT_CONTENT; li: Longint = -1): TFormatEtc;
begin
   with Result do
      begin
         cfFormat := cf;
         dwAspect := asp;
         ptd := td;
         tymed := med;
         lindex := li
      end
end;

function OleSwitchDisplayAspect(OleObject: IOleObject; var CurrentAspect: DWORD;
   NewAspect: DWORD; METAFILEPICT: THandle; DeleteOldAspect, SetUpViewAdvise: boolean;
   AdviseSink: IAdviseSink; var MustUpdate: boolean): HRESULT;
var
   OleCache: IOleCache;
   ViewObject: IViewObject;
   EnumStatData: IEnumStatData;
   StatData: TStatData;
   FormatEtc: TFormatEtc;
   Medium: TStgMedium;
   Advf,
      NewConnection,
      OldAspect: longint;
   Error: HRESULT;
begin
   OleCache := nil;
   ViewObject := nil;
   EnumStatData := nil;
   OldAspect := CurrentAspect;
   MustUpdate := False;
   if Failed(OleObject.QueryInterface(IOleCache, OleCache)) then
      begin
         Result := E_INVALIDARG;
         Exit
      end;
   FormatEtc := SetFormatEtc(0, TYMED_NULL, nil, NewAspect);
   if (NewAspect = dvaspect_Icon) and (METAFILEPICT <> 0) then
      Advf := advf_nodata
   else
      Advf := ADVF_PRIMEFIRST;
   Result := OleCache.Cache(FormatEtc, Advf, NewConnection);
   if Failed(Result) then
      Exit;
   CurrentAspect := NewAspect;
   if (NewAspect = dvaspect_Icon) and (METAFILEPICT <> 0) then
      begin
         FormatEtc := SetFormatEtc(CF_METAFILEPICT, TYMED_MFPICT, nil, dvaspect_Icon);
         Medium := SetStgMedium(TYMED_MFPICT, METAFILEPICT);
         OleCache.SetData(FormatEtc, Medium, False)
      end
   else
      MustUpdate := True;
   if SetUpViewAdvise and Assigned(AdviseSink) then
      if Succeeded(OleObject.QueryInterface(IViewObject, ViewObject)) then
         begin
            ViewObject.SetAdvise(NewAspect, 0, AdviseSink);
            ViewObject := nil
         end;
   if DeleteOldAspect then
      begin
         Error := OleCache.EnumCache(EnumStatData);
         while Error = S_OK do
            begin
               Error := EnumStatData.Next(1, StatData, nil);
               if Error = S_OK then
                  if StatData.FormatEtc.dwAspect = OldAspect then
                     OleCache.Uncache(StatData.dwConnection)
            end
      end;
   Result := S_OK
end;

function GetOleClassFile(const Name: string): TCLSID;
var
   Buffer: POleStr;
begin
   Result := CLSID_NULL;
   Buffer := OleCopyPasString(Name);
   try
      OleCheck(GetClassFile(Buffer, Result))
   finally
      if Assigned(Buffer) then
         OleFreeString(Buffer)
   end
end;

function OleCopyPasString(const Source: string; Malloc: IMalloc = nil): POleStr;
var
   Size: Integer;
begin
   Size := Length(Source);
   if Size = 0 then
      Result := nil
   else
      begin
         Inc(Size);
         Result := OleMalloc(Size * SizeOf(WideChar), Malloc);
         if not Assigned(Result) then
            OutOfMemoryError;
         StringToWideChar(Source, Result, Size)
      end
end;

function SetStgMedium(Stg, Handle: longint; Release: pointer = nil): TStgMedium;
begin
   Result.tymed := Stg;
   Result.hGlobal := Handle;
   Result.unkForRelease := Release
end;

procedure OleFreeString(Str: POleStr; Malloc: IMalloc = nil);
begin
   OleFree(Str, Malloc)
end;

function OleMalloc(Size: Longword; Malloc: IMalloc = nil): pointer;
begin
   if not Assigned(Malloc) then
      Result := CoTaskMemAlloc(Size)
   else
      Result := Malloc.Alloc(Size)
end;

procedure OleFree(Mem: pointer; Malloc: IMalloc = nil);
var
   Ok: Integer;
begin
   if not Assigned(Malloc) then
      begin
         Ok := CoGetMalloc(MEMCTX_TASK, Malloc);
         if Ok = NOERROR then
            Assert(Ok = NOERROR, 'CoGetMalloc');
      end;
   Ok := Malloc.DidAlloc(Mem);
   if Ok = S_FALSE then
      Assert(Ok = S_FALSE, 'Impossible to free the memory');
   Malloc.Free(Mem)
end;

procedure ChangeOleIcon(REdit: TRichEdit; HIcon: Hwnd; LabelIcon: string);
var
   Update: Boolean;
   Selectiontype: Integer;
   RichEditOle: IRichEditOle;
   OleClientSite: IOleClientSite;
   REObject: TReObject;
begin
   Update := True;
   FillChar(ReObject, SizeOf(ReObject), 0);
   ReObject.cbStruct := SizeOf(ReObject);
   Selectiontype := SendMessage(Redit.Handle, EM_SELECTIONtype, 0, 0);
   if selectionType = SEL_OBJECT then
      GetRichOleInterface(REdit, RichEditOle, OleClientSite);
   OleCheck(RichEditOle.GetObject(Longint(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ or REO_GETOBJ_POLESITE));
   HIcon := OleMetafilePictFromIconAndLabel(Hicon, OleCopyPasString(LabelIcon), '', 0);
   OleSwitchDisplayAspect(REObject.oleobj, REObject.dvaspect, REObject.dvaspect, Hicon, False, False, nil, Update);
   OleCheck(REobject.oleobj.Update);
end;

function TRichEditWB.ConvertBitmapToRTF(pict: TBitmap): string;
var
   bi, bb, rtf: string;
   bis, bbs: Cardinal;
   achar: ShortString;
   hexpict: string;
   I: Integer;
begin
   GetDIBSizes(pict.Handle, bis, bbs);
   SetLength(bi, bis);
   SetLength(bb, bbs);
   GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
   rtf := '{\rtf1 {\pict\dibitmap ';
   SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
   I := 2;
   for bis := 1 to Length(bi) do
      begin
         achar := Format('%x', [Integer(bi[bis])]);
         if Length(achar) = 1 then
            achar := '0' + achar;
         hexpict[I - 1] := achar[1];
         hexpict[I] := achar[2];
         Inc(I, 2);
      end;
   for bbs := 1 to Length(bb) do
      begin
         achar := Format('%x', [Integer(bb[bbs])]);
         if Length(achar) = 1 then
            achar := '0' + achar;
         hexpict[I - 1] := achar[1];
         hexpict[I] := achar[2];
         Inc(I, 2);
      end;
   rtf := rtf + hexpict + ' }}';
   Result := rtf;
end;

function TRichEditWB.AddFiles(Files: TStrings; Linked: bool; AsIcon: Bool): integer;
var
   I: Integer;
   FilePath: string;
   Ind: word;
   HIcon: hwnd;
   Update: boolean;
   OleClientSite: IOleClientSite;
   Storage: IStorage;
   OleObject: IOleObject;
   ReObject: TReObject;
   RichEditOle: IrichEditOle;
begin
   Ind := 1;
   Update := True;
   FillChar(ReObject, SizeOf(TReObject), 0);
   for I := 0 to Files.Count - 1 do
      begin
         FilePath := Files[I];
         if GetRichOleInterface(Self, RichEDitOle, OleClientSite) then
            begin
               Storage := nil;
               try
                  CreateIStorage(Storage);
                  if Linked then
                     OleCheck(OleCreateLinkToFile(OleCopyPasString(FilePath), IOleObject, OLERendER_DRAW, nil, OleClientSite, Storage, OleObject))
                  else
                     OleCheck(OleCreateLinkToFile(OleCopyPasString(FilePath), IOleObject, OLERendER_DRAW, nil, OleClientSite, Storage, OleObject));
                  with ReObject do
                     begin
                        cbStruct := SizeOf(TReObject);
                        cp := Integer(REO_CP_SELECTION);
                        OleObject.GetUserClassId(CLSID);
                        oleobj := OleObject;
                        stg := Storage;
                        olesite := OleClientSite;
                        if Asicon then
                           DvAspect := DVASPECT_ICON
                        else
                           DvAspect := DVASPECT_CONTENT;
                        dwFlags := REO_RESIZABLE or REO_DYNAMICSIZE;
                     end;
                  if IsEqualCLSID(REObject.CLSID, CLSID_NULL) then
                     REObject.CLSID := GetOleClassFile(FilePath);
                  HIcon := ShellAPI.ExtractAssociatedIcon(Application.Handle, PChar(FilePath), Ind);
                  HIcon := OleMetafilePictFromIconAndLabel(Hicon, OleCopyPasString(ExtractFileName(FilePath)), '', 0);
                  OleSwitchDisplayAspect(OleObject, REObject.dvaspect, REObject.dvaspect, Hicon, False, False, nil, Update);
                  OleCheck(RichEditOle.InsertObject(ReObject));
                  SendMessage(Self.Handle, EM_SCROLLCARET, 0, 0);
                  OleCheck(OleObject.Update);
               finally
                  OleClientSite := nil;
                  Storage := nil;
               end;
            end;
      end;
   Result := Lines.Count;
end;

function TRichEditWB.AddFile(FilePath: string; Linked: bool; AsIcon: Bool): integer;
var
   Ind: word;
   HIcon: hwnd;
   Update: boolean;
   OleClientSite: IOleClientSite;
   Storage: IStorage;
   OleObject: IOleObject;
   ReObject: TReObject;
   RichEditOle: IrichEditOle;
begin
   inserted := true;
   Ind := 1;
   Update := True;
   FillChar(ReObject, SizeOf(TReObject), 0);
   if GetRichOleInterface(Self, RichEDitOle, OleClientSite) then
      begin
         Storage := nil;
         try
            CreateIStorage(Storage);
            if Linked then
               OleCheck(OleCreateLinkToFile(OleCopyPasString(FilePath),
                  IOleObject, OLERendER_DRAW, nil, OleClientSite, Storage, OleObject))
            else
               OleCheck(OleCreateLinkToFile(OleCopyPasString(FilePath),
                  IOleObject, OLERendER_DRAW, nil, OleClientSite, Storage, OleObject));
            with ReObject do
               begin
                  cbStruct := SizeOf(TReObject);
                  cp := Integer(REO_CP_SELECTION);
                  OleObject.GetUserClassId(CLSID);
                  oleobj := OleObject;
                  stg := Storage;
                  olesite := OleClientSite;
                  if Asicon then
                     DvAspect := DVASPECT_ICON
                  else
                     DvAspect := DVASPECT_CONTENT;
                  dwFlags := REO_RESIZABLE or REO_DYNAMICSIZE;
               end;
            if IsEqualCLSID(REObject.CLSID, CLSID_NULL) then
               REObject.CLSID := GetOleClassFile(FilePath);
            HIcon := ShellAPI.ExtractAssociatedIcon(Application.Handle, PChar(FilePath), Ind);
            HIcon := OleMetafilePictFromIconAndLabel(Hicon, OleCopyPasString(ExtractFileName(FilePath)), '', 0);
            OleSwitchDisplayAspect(OleObject, REObject.dvaspect, REObject.dvaspect, Hicon, False, False, nil, Update);
            OleCheck(RichEditOle.InsertObject(ReObject));
            SendMessage(Self.Handle, EM_SCROLLCARET, 0, 0);
            OleCheck(OleObject.Update);
         finally
            OleClientSite := nil;
            Storage := nil;
         end;
      end;
   result := Lines.Count;
end;

procedure AddbBitmapToRichEdit(bmp: Tbitmap; RichEdit: TRichEditWB);

   function BitmapToRTF(pict: TBitmap): string;
   var
      bi, bb, rtf: string;
      bis, bbs: Cardinal;
      achar: ShortString;
      hexpict: string;
      I: Integer;
   begin
      GetDIBSizes(pict.Handle, bis, bbs);
      SetLength(bi, bis);
      SetLength(bb, bbs);
      GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
      rtf := '{\rtf1 {\pict\dibitmap ';
      SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
      I := 2;
      for bis := 1 to Length(bi) do
         begin
            achar := Format('%x', [Integer(bi[bis])]);
            if Length(achar) = 1 then
               achar := '0' + achar;
            hexpict[I - 1] := achar[1];
            hexpict[I] := achar[2];
            Inc(I, 2);
         end;
      for bbs := 1 to Length(bb) do
         begin
            achar := Format('%x', [Integer(bb[bbs])]);
            if Length(achar) = 1 then
               achar := '0' + achar;
            hexpict[I - 1] := achar[1];
            hexpict[I] := achar[2];
            Inc(I, 2);
         end;
      rtf := rtf + hexpict + ' }}';
      Result := rtf;
   end;
var
   s: TstringStream;
begin
   S := TStringStream.Create(BitmapToRTF(bmp));
   RichEdit.PlainText := False;
 // RichEdit.StreamMode := [smSelection];
   RichEdit.Lines.LoadFromStream(S);
   S.Free;
end;

function TRichEditWB.AddImages(Files: TStrings): integer;
var
   Ext: string;
   Pict: TPicture;
   I: Integer;
begin
   Result := 0;
   Pict := TPicture.Create;
   try
      for I := 0 to Files.Count - 1 do