Как получить RTF из Word без буффера обмена?

Previous  Top  Next

    
 

 

 

Code:

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.Next(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;

 

 

©Drkb::04435

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php