uses
 Word_TLB, ActiveX, ComObj;
function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
 Formats: IEnumFORMATETC;
 TempFormat: TFormatEtc;
 pFormatName: PChar;
 Found: Boolean;
begin
 try
  OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
  Found := False;
  while (not Found) and (Formats.(1, TempFormat, nil) = S_OK) do
  begin
  pFormatName := AllocMem(255);
  GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
  if (string(pFormatName) = 'Rich Text Format') then
  begin
  RTFFormat := TempFormat;
  Found := True;
  end;
  FreeMem(pFormatName);
  end;
  Result := Found;
 except
  Result := False;
 end;
end;
function GetRTF: string;
var
 DataObject: IDataObject;
 RTFFormat: TFormatEtc;
 ReturnData: TStgMedium;
 Buffer: PChar;
 WordDoc: _Document;
 WordApp: _Application;
begin
 Result := '';
 try
  GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
 except
  ShowMessage('Error: MSWord is not running');
  Exit;
 end;
 if (WordApp <> nil) then
  try
  WordDoc := WordApp.ActiveDocument;
  WordDoc.QueryInterface(IDataObject, DataObject);
  if GetRTFFormat(DataObject, RTFFormat) then
  begin
  OleCheck(DataObject.GetData(RTFFormat, ReturnData));
  //RTF is passed through global memory
  Buffer := GlobalLock(ReturnData.hglobal);
  //Buffer is a pointer to the RTF text
  Result := StrPas(Buffer);
  GlobalUnlock(ReturnData.hglobal);
  ReleaseStgMedium(ReturnData);
  end;
  except
  // Error occured...
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 ss: TStringstream;
 rtfText: string;
begin
 rtfText := GetRTF;
 ss := TStringStream.Create(rtfText);
 try
  ss.Position := 0;
  Memo1.Text := rtfText;
  RichEdit1.Lines.LoadFromStream(ss);
 finally
  ss.Free
 end;
end;