Модераторы: Snowy, MetalFan, bems, Poseidon
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Как извлечь все картинки из RichEdit? 
:(
    Опции темы
Alexey89
Дата 8.9.2018, 15:20 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 13
Регистрация: 24.7.2015

Репутация: нет
Всего: нет



Здравствуйте! Есть один пример который позволяет добавлять Картинки в RichEdit'e, вместо букв! . Мне необходимо сделать обратный процесс извлечь и сохранить все картинки в какую-нибудь папку.
У меня получилось извлечь и сохранить только одну картинку и то с помощью перетаскивания, её на форму. (Код на 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;



Это сообщение отредактировал(а) Alexey89 - 8.9.2018, 15:24
PM MAIL   Вверх
starikanisbackbaby
Дата 8.9.2018, 16:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 5
Регистрация: 8.9.2018

Репутация: нет
Всего: нет



Решается очень просто, держи я тебе кодец накидал.

Код

procedure TForm1.ScanResourse;
var
hNetEnum: THandle;
NetContainerToOpen: NETRESOURCE;
ResourceBuffer: array[1..2000] of TNetResource;
i, ResourceBuf, EntriesToGet: DWORD;
ip:string;
name:string;
f:TextFile;
ii:Integer;
s:Integer;
ini:TiniFIle;
begin
Log.Clear;
NetContainerToOpen.dwScope:=RESOURCE_GLOBALNET;
NetContainerToOpen.dwType:=RESOURCETYPE_ANY;
NetContainerToOpen.lpLocalName:=nil;
NetContainerToOpen.lpRemoteName:= PChar('\\' + name);
NetContainerToOpen.lpProvider:= nil;
WNetOpenEnum (RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
     RESOURCEUSAGE_CONNECTABLE or RESOURCEUSAGE_CONTAINER,
     @NetContainerToOpen, hNetEnum);     
while TRUE do
  begin
    ResourceBuf := sizeof(ResourceBuffer);
     EntriesToGet:=2000;
    if (NO_ERROR <> WNetEnumResource(hNetEnum, EntriesToGet,
              @ResourceBuffer, ResourceBuf)) then
          begin
           WNetCloseEnum(hNetEnum) ;
           exit;
          end;
          for i := 1 to EntriesToGet do
              Log.AddTextFromNewLine(string(ResourceBuffer[i].lpRemoteName), 0); //Вот я добавляю в RichView все найденые
              Log.Format; 
             end;

PM MAIL   Вверх
Alexey89
Дата 8.9.2018, 17:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 13
Регистрация: 24.7.2015

Репутация: нет
Всего: нет



Что за Log, 15 строка Log.Clear (компонент)?
PM MAIL   Вверх
starikanisbackbaby
Дата 8.9.2018, 17:56 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 5
Регистрация: 8.9.2018

Репутация: нет
Всего: нет



это массив протокольных значений
PM MAIL   Вверх
Alexey89
Дата 8.9.2018, 17:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 13
Регистрация: 24.7.2015

Репутация: нет
Всего: нет



Что то вы не то выложили. В предпоследнем посту "Как в RichView'e вывести строку", точно такой же код.

Добавлено через 3 минуты и 23 секунды
Скачал пример с предпоследнего поста, он вообще к моей программе не подходит, у меня delphi 7, а там версия нужна выше.
PM MAIL   Вверх
starikanisbackbaby
Дата 8.9.2018, 18:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 5
Регистрация: 8.9.2018

Репутация: нет
Всего: нет



Смотрит внимательнее, все правильно. Обнови версию.
PM MAIL   Вверх
Google
  Дата 21.9.2018, 16:38 (ссылка)  





  Вверх
  
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Для новичков"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Для новичков | Следующая тема »


 




[ Время генерации скрипта: 0.0880 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.