How to copy text from a TRichEdit to the clipboard with a different font than the original

Problem/Question/Abstract:

I need to ensure that when my TRichEdit copies text to the clipboard, it is copied in a certain font, colour and size. My problem is that my TRichEdit is defaulted to one font and the users are not given the ability to change it. But I want it to pasted into Word (for example) in another font.

Answer:

You can of course compose a rich text file in code and copy that into the clipboard using the standard rich edit clipboard format, but it's a lot of work. A somewhat simpler approach may be to take the rich text as it is in the control (stream to a TMemoryStream, load into a String) and then modify the \fonttbl tag in the file.

procedure TForm1.Button3Click(Sender: TObject);
var
  S: string;
  ss: TStringstream;
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    richedit1.Lines.SaveToStream(ms);
    SetString(S, Pchar(ms.Memory), ms.size);
  finally
    ms.free
  end;
  memo1.text := S; {view raw rtf in TMemo to see font table}
  S := Stringreplace(S, 'Times New Roman', 'Verdana', []);
  ss := TStringstream.Create(S);
  try
    richedit1.Lines.LoadFromStream(ss);
  finally
    ss.free
  end;
end;

To get the new text into the clipboard proceed as below:

uses
  Richedit, Clipbrd;

{$R *.dfm}

procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var
  hMem: THandle;
  pMem: Pointer;
begin
  {Rewind stream position to start}
  S.Position := 0;
  {Allocate a global memory block the size of the stream data}
  hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
  if hMem <> 0 then
  begin
    {Succeeded, lock the memory handle to get a pointer to the memory}
    pMem := GlobalLock(hMem);
    if pMem <> nil then
    begin
      {Succeeded, now read the stream contents into the memory the pointer points at}
      try
        S.Read(pMem^, S.Size);
        {Rewind stream again, caller may be confused if the stream position is
                         left at the end}
        S.Position := 0;
      finally
        {Unlock the memory block}
        GlobalUnlock(hMem);
      end;
      {Open clipboard and put the block into it. The way the Delphi clipboard
                        object is written this will clear the clipboard first.
                         Make sure the clipboard is closed even in case of an exception. If left open
      it would become unusable for other apps.}
      Clipboard.Open;
      try
        Clipboard.SetAsHandle(fmt, hMem);
      finally
        Clipboard.Close;
      end;
    end
    else
    begin
      {Could not lock the memory block, so free it again and raise an out of
                        memory exception}
      GlobalFree(hMem);
      OutOfMemoryError;
    end;
  end
  else
    {Failed to allocate the memory block, raise exception}
    OutOfMemoryError;
end;

var
  CF_RTF: Word = 0; {set in Initialization section}

procedure TForm1.Button3Click(Sender: TObject);
var
  S: string;
  ss: TStringstream;
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    richedit1.Lines.SaveToStream(ms);
    SetString(S, Pchar(ms.Memory), ms.size);
  finally
    ms.free
  end;
  S := Stringreplace(S, 'Times New Roman', 'Verdana', []);
  ss := TStringstream.Create(S);
  try
    // richedit1.Lines.LoadFromStream(ss);
    CopyStreamToClipboard(CF_RTF, ss);
  finally
    ss.free
  end;
end;

initialization
  CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);
end.