uses
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 ConvertToBMP(DataObject: IDataObject; Document:
string): Boolean;
var
FormatEtc: TFormatEtc;
Medium: TStgMedium;
Bitmap: TBitmap;
begin
// OLEContainer.OLEObjectInterface.QueryInterface(IDataObject, DataObject);
if DataObject <>
nil then
begin
Result := True;
FormatEtc.cfFormat := CF_BITMAP;
FormatEtc.ptd :=
nil;
FormatEtc.dwAspect := DVASPECT_CONTENT;
FormatEtc.lIndex := -1;
FormatEtc.tymed := TYMED_GDI;
if DataObject.GetData(FormatEtc, Medium) >= 0
then
begin
try
Bitmap := TBitmap.Create;
Bitmap.LoadFromClipboardFormat(CF_BITMAP, Medium.hBitmap, 0);
Bitmap.SaveToFile(Document);
ReleaseStgMedium(Medium);
finally
Bitmap.Free;
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
DataObject: IDataObject;
RTFFormat: TFormatEtc;
ReturnData: TStgMedium;
Buffer: PChar;
ExcelWB: _WorkBook;
ExcelApp: _Application;
begin
try
GetActiveOleObject('
Excel.Application').QueryInterface(_Application, ExcelApp);
except
ShowMessage('
Error: Excel is not running');
Exit;
end;
if (ExcelApp <>
nil)
then
try
ExcelWB := ExcelApp.ActiveWorkbook;
ExcelWB.QueryInterface(IDataObject, DataObject);
if ConvertToBMP(DataObject,'
c:\test.bmp')
then
begin
Caption := '
ok';
end;
except
// Fehler aufgetreten...
end;
end;