Здравствуйте! Есть один пример который позволяет добавлять http://forum.vingrad.ru/forum/topic-106795.html. Мне необходимо сделать обратный процесс извлечь и сохранить все картинки в какую-нибудь папку.
У меня получилось извлечь и сохранить только одну картинку и то с помощью перетаскивания, её на форму. (Код на Delphi 7)
| Код |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RichEdit, ExtDlgs, ComCtrls, ExtCtrls, ActiveX, ComObj, re_bmp;
type
TForm1 = class(TForm)
Image1: TImage;
RichEdit1: TRichEdit;
OpenPictureDialog1: TOpenPictureDialog;
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TMyDropTarget = class(TInterfacedObject, IDropTarget)
protected
function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function DragOver(grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
var dwEffect: Longint): HResult; stdcall;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
begin
Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
InsertBitmapToRE(RichEdit1.Handle, Image1.Picture.Bitmap.Handle);
end;
end;
{ TMyDropTarget }
function TMyDropTarget.DragEnter(const dataObj: IDataObject;
grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
Result := S_OK;
end;
function TMyDropTarget.DragLeave: HResult;
begin
Result := S_OK;
end;
function TMyDropTarget.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HResult;
begin
Result := S_OK;
end;
function TMyDropTarget.Drop(const dataObj: IDataObject;
grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
IREO:IRichEditOle;
ReObject:TReobject;
Count:Integer;
I:Integer;
FMT : FORMATETC;
MED : STGMEDIUM;
Path:String;
dataObj1:IDataObject;
bmp:TBitmap;
Position:LongInt;
BitsLength:UINT;
MetaFile:TMetafile;
Bits:Pointer;
MetafilePictPtr: PMetafilePict;
begin
Path:='C:\_temp\richedit\';
SendMessage(Form1.RichEdit1.Handle, EM_GETOLEINTERFACE, 0, Longint(@IREO));
Count:=IREO.GetObjectCount;
for I := 0 to Count - 1 do
begin
ZeroMemory(@ReObject,SizeOf(ReObject));
ReObject.cbStruct:=SizeOf(ReObject);
if Succeeded(IREO.GetObject(I,ReObject, $00000001))
then
begin
Position:=ReObject.cp;
Form1.Edit1.Text:=IntToStr(Position);
if ReObject.poleobj.QueryInterface(IDataObject,dataObj1)=S_OK then
begin
FMT.cfFormat := CF_METAFILEPICT;
FMT.ptd := nil;
FMT.dwAspect := DVASPECT_CONTENT;
FMT.lindex := -1;
FMT.tymed := TYMED_MFPICT;
if Succeeded(dataObj.GetData(FMT,MED)) then
try
MetafilePictPtr:=GlobalLock(MED.hMetaFilePict);
try
BitsLength:=GetMetaFileBitsEx(MetafilePictPtr.hMF,0,nil);
GetMem(Bits,BitsLength);
try
if GetMetaFileBitsEx(MetaFilePictPtr.hMF,BitsLength, Bits) < BitsLength then RaiseLastOSError;
MetaFile:=TMetafile.Create;
MetaFile.Handle:=SetWinMetaFileBits(BitsLength,Bits,0,MetafilePictPtr^);
if (MetaFile.Width<=0) or (MetaFile.Height<=0) then raise Exception.Create('Invalid Metafile-Picture');
bmp:=TBitmap.Create;
bmp.Width:=MetaFile.Width;
bmp.Height:=MetaFile.Height;
bmp.Canvas.StretchDraw(Rect(0,0,bmp.Width,bmp.Height),MetaFile);
bmp.SaveToFile(Path+'Img'+IntToStr(I+1)+'.bmp');
finally
bmp.Free;
MetaFile.Free;
FreeMem(Bits,BitsLength);
end;
finally
GlobalUnlock(MED.hMetaFilePict)
end;
finally
ReleaseStgMedium(MED);
end;
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
I : IDropTarget;
begin
//Регистрируем окно как получателя перетаскивания
OleInitialize(nil);
I := TMyDropTarget.Create;
OLECheck( CoLockObjectExternal(I, true, false) );
OLECheck( RegisterDragDrop(Handle, I) );
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
OLECheck( RevokeDragDrop(Handle) );
except
Application.HandleException(Self);
end;
OleUninitialize;
end;
end.
|
Подскажите пожалуйста, как извлечь все картинки при нажатии кнопки, например вот так.
(Пробовал не получилось)
| Код |
procedure TForm1.Button2Click(Sender: TObject);
var
IREO:IRichEditOle;
ReObject:TReobject;
Count:Integer;
I:Integer;
FMT : FORMATETC;
MED : STGMEDIUM;
Path:String;
dataObj1:IDataObject;
bmp:TBitmap;
Position:LongInt;
BitsLength:UINT;
MetaFile:TMetafile;
Bits:Pointer;
MetafilePictPtr: PMetafilePict;
begin
Path:='C:\_temp\richedit\';
SendMessage(Form1.RichEdit1.Handle, EM_GETOLEINTERFACE, 0, Longint(@IREO));
Count:=IREO.GetObjectCount;
for I := 0 to Count - 1 do
begin
ZeroMemory(@ReObject,SizeOf(ReObject));
ReObject.cbStruct:=SizeOf(ReObject);
if Succeeded(IREO.GetObject(I,ReObject, $00000001))
then
begin
Position:=ReObject.cp;
Form1.Edit1.Text:=IntToStr(Position);
if ReObject.poleobj.QueryInterface(IDataObject,dataObj1)=S_OK then
begin
FMT.cfFormat := CF_METAFILEPICT;
FMT.ptd := nil;
FMT.dwAspect := DVASPECT_CONTENT;
FMT.lindex := -1;
FMT.tymed := TYMED_MFPICT;
if Succeeded(dataObj1.GetData(FMT,MED)) then
try
MetafilePictPtr:=GlobalLock(MED.hMetaFilePict);
try
BitsLength:=GetMetaFileBitsEx(MetafilePictPtr.hMF,0,nil);
GetMem(Bits,BitsLength);
try
if GetMetaFileBitsEx(MetaFilePictPtr.hMF,BitsLength, Bits) < BitsLength then RaiseLastOSError;
MetaFile:=TMetafile.Create;
MetaFile.Handle:=SetWinMetaFileBits(BitsLength,Bits,0,MetafilePictPtr^);
if (MetaFile.Width<=0) or (MetaFile.Height<=0) then raise Exception.Create('Invalid Metafile-Picture');
bmp:=TBitmap.Create;
bmp.Width:=MetaFile.Width;
bmp.Height:=MetaFile.Height;
bmp.Canvas.StretchDraw(Rect(0,0,bmp.Width,bmp.Height),MetaFile);
bmp.SaveToFile(Path+'Img'+IntToStr(I+1)+'.bmp');
finally
bmp.Free;
MetaFile.Free;
FreeMem(Bits,BitsLength);
end;
finally
GlobalUnlock(MED.hMetaFilePict)
end;
finally
ReleaseStgMedium(MED);
end;
end;
end;
end;
end;
|
|