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

Поиск:

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


Новичок



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

Репутация: нет
Всего: нет
Здравствуйте! Есть один пример который позволяет добавлять Картинки в RichEdit'e, вместо букв! . Мне необходимо сделать обратный процесс извлечь и сохранить все картинки в какую-нибудь папку.
У меня получилось извлечь и сохранить только одну картинку и то с помощью перетаскивания, её на форму. (Код на Delphi 7)
Выделить всёРазвернуть кодкод Pascal/Delphi
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
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.

Подскажите пожалуйста, как извлечь все картинки при нажатии кнопки, например вот так.
(Пробовал не получилось)
Выделить всёРазвернуть кодкод Pascal/Delphi
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
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

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

Выделить всёРазвернуть кодкод Pascal/Delphi
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
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 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 16
Регистрация: 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 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

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

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


Новичок



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

Репутация: нет
Всего: нет
Смотрит внимательнее, все правильно. Обнови версию.
PM MAIL   Вверх
  
 Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Для новичков"
SnowyMetalFan
bemsPoseidon
Rrader

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

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

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

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

Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.
 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Для новичков | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




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


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

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