Картинка из интернета прямая загрузка в TImage [РЕШЕНО]

[Alex2013]

Народ как помощью например synapse получить картинку из интернета и по прямой ссылке и загрузить ее в TImage ?
Для дефльфи рецепт нашел ...

Код: Выделить всё

Str:=TMemoryStream.create;
Http.Get('http://*.*, str);
Str.Seek(0,soFromBeginning);
Image1.Picture.LoadFromStream(str);
Str.free;


А в лазарусе что-то не то ... не грузит !

Код: Выделить всё

HTTP := THTTPSend.Create;
   Result :=  HTTP.HTTPMethod('GET', 'http://...');
if Result then
    Image1.Picture.LoadFromStream(HTTP.Document);
HTTP.free;


Где я напортачил ?

[pupsik]

HTTP.Document ....Seek(0,soFromBeginning)

[Alex2013]

HTTP.Document ....Seek(0,soFromBeginning)

Спасибо за отзыв но это HTTP.HTTPMethod('GET', 'http://...'); сам делает ...
(И я тоже пробовал делать HTTP.Document.Seek не помогло ... там что-то с форматом данных нездоровое делается )

Но пока ждал ответа самостоятельно нарыл другое решение ....

Код: Выделить всё

var s:TMemoryStream;
begin
s:=TMemoryStream.Create;
HttpGetBinary('http://127.0.0.1/ban0.jpg', s); // Хорошо  иметь свой сервер в столице ...  :)
s.Seek(0, soFromBeginning);
  Image1.Picture.LoadFromStream(S);
  Image1.Refresh;
s.Free;
end;


Так что всем спасибо "все решено могучи ураганом !"

[pupsik]

Alex2013 вот кто его знает....
но всё работает

Код: Выделить всё

const
  im_url = 'http://freepascal.ru/images/logo.png';
var
  im_get : THTTPSend;
begin
  im_get := THTTPSend.Create;
  im_get.HTTPMethod('GET', im_url);
  if im_get.ResultCode = 200 then
    Image1.Picture.LoadFromStream(im_get.Document)
  else
    ShowMessage(inttostr(im_get.ResultCode));
  FreeAndNil(im_get);


Т.е. картинка грузится и т.д... Вместо ResultCode можно "повесить" ответ сервера.

То что поток в начало переводится - моя привычка. Не всегда он там где хочется (т.е. не во всём).

Result := HTTP.HTTPMethod('GET', 'http://...'); .... Ну вернёт он вам True. И что это даст?

[Alex2013]

Ну у меня мой код уже работает в реальных условиях ... ( то есть с возможностью ошибок в адресе )

Текущая версия загрузчика :

Код: Выделить всё

//Загрузка изображений из сети
procedure NetLoadImg(Url:String;var BMP:Tbitmap );
var
Image1:TImage;
s:TMemoryStream;
begin
if bmp<>Nil then bmp.Free;
s:=TMemoryStream.Create;
If HttpGetBinary(URL, s) then begin
BMP:=Tbitmap.Create;
s.Seek(0, soFromBeginning);
  Image1:=TImage.Create(nil);
  Image1.Picture.LoadFromStream(S);
  bmp.Assign(Image1.Picture.Bitmap);
  Image1.Free;
end ;
s.Free;
end;


Правда при ошибочном адресе действительно подтормаживает ...
Но для конкретной задачи это пока несущественно ..
Ваш вариант явно будет тормозить точно также .
Вот если бы сделать более быструю проверку валидности адреса ДО вызова загрузки .
вот это было бы реально полезно !

[pupsik]

Правда при ошибочном адресе действительно подтормаживает

не совсем понятно. Т.е. обычно задействуется поток. Как у вас... к.з..

HttpGetBinary - та же шапка.... что и:

Ваш вариант явно будет тормозить точно также .

это не мой вариант, а стандарт для синапсе...

Вот если бы сделать более быструю проверку валидности адреса ДО вызова загрузки .

не понимаю что вы имеете ввиду но:
1. ResultCode
2. Ответ сервера
3. Валидность юрл (проверка строки адреса на соответствие) - есть функции в инете (вроде и в лазаре да и в синапсе)

[Alex2013]

не понимаю что вы имеете ввиду но:
1. ResultCode
2. Ответ сервера
3. Валидность юрл (проверка строки адреса на соответствие) - есть функции в инете (вроде и в лазаре да и в синапсе)

Я имею ввиду просто возможность быстро "пропинговать" адрес не пытаясь загрузить + после считать заголовок и только потом в случае "полного успеха" читать данные ну и проверка конкретности URL адреса вообще (с этим все понятно ). Хотя проблема чуть надуманная просто у меня ввод строки сопровождается ее использованием качестве URL что разумеется не совсем правильно Нужно сделать текущий адрес + возможность его изменить по кнопке.
(Хотя "живой поиск" в браузерах ведь как-то работает и не тормозит... Верно ? Значит можно сделать подобный "финт ушами" и в своих программах )

Зы
Тут новая проблема образовалась "на ровном месте" если урл содержит порт загрузка начинает страшно и непонятно ругаться (что-то про потоки) и не работает ... Вопрос есть ли в синапсе возможность сменить http порт с 80-го на произвольный (Для прокси ведь ввод порта есть )

[Лекс Айрин]

Хотя "живой поиск" в браузерах ведь как-то работает и не тормозит... Верно ? Значит можно сделать подобный "финт ушами" и в своих программах

Твой "живой" поиск это постоянно отправляемый на сервер запрос со всеми вытекающими.

[pupsik]

Я имею ввиду просто возможность быстро "пропинговать" адрес не пытаясь загрузить...

дык синапс, вроде как, пингует... Или вам необходим бубен который по какой то строке сможет узнать: есть адресс или нет

[Alex2013]

Опять что-то не так! Я тут вроде добавил возможность использовать нестандартный порт ...
(Просто в место не типизированной константы сделал типизированную

Код: Выделить всё

unit httpsend;
interface
uses
  SysUtils, Classes,
  blcksock, synautil, synaip, synacode, synsock;
const
  cHttpProtocol:String = '80';
...


)
С моим сервером все работает на ура ...
А тем что в IP WebCam на смартфоне работать не хочет.
( Локальный адрес http://192.168.0.101:1024/shot.jpg Браузере видит а в программе нет ...
Хотя вот эту камеру с 81 порта видит http://mozart.amadeus-hotel.com:81/view ... /image.jpg )
Я в догадках теряюсь ... может там JPG какой-то кривой ?

[pupsik]

может там JPG какой-то кривой ?

1. Что в шапке ответа сервера?
2. Что в теле потока?
Сохраните полученный файл на диск и просмотрите что сохранилось. И т.д., и т.п...

п.с.

Опять что-то не так!

первый раз что ли?

[Alex2013]

Старая тема Уровень 2
Нужна быстрая и надежная загрузка списка изображений в многопоточном режиме .
( Вроде и просто, однако бьюсь уже два дня, но все что пишу нормально не работает )
Есть вот такой поток (Он работает хотя и не очень надежно )

Код: Выделить всё

Type
TLoadPicThread=Class(TThread)
  private
  protected
    procedure Execute; override;
    procedure Load;
    procedure SLoad;

  public
   UPDATE  :Boolean;
    fIM: Timage;
    fURL:String;

    constructor Create(CreateSuspended: boolean;URL:
                            String;Var Im: Timage );
  end;

procedure TLoadPicThread.Load;
Var
B:TBitmap;
begin
try
If FProgSetting.F_SPic then
   B:=RE_NetLoadBMP_PHP(fURL,FProgSetting.ScImW,FProgSetting.ScImH,True) else
   B:=RE_NetLoadBMP_PHP(fURL);
if b.Modified then fIm.Picture.Bitmap.Assign(B);
  fIm.Picture.Bitmap.Modified:=b.Modified;
  B.Free;
  except
end;
end;
procedure TLoadPicThread.SLoad;
begin
Sleep(10);
end;

procedure  TLoadPicThread.Execute;
Var
B:TBitmap;
begin
while (not Terminated) do
If  UPDATE then begin
Synchronize(@SLoad);
Load;
T_UPDATE:=T_UPDATE+1;
T_End:=T_Count = T_UPDATE;
UPDATE  :=False;
Terminate;
end;
end;

constructor  TLoadPicThread.Create(CreateSuspended: boolean;URL:
                                     String;Var Im: Timage);
begin
  UPDATE  := False;
  fIM:=im;
  fUrl:=Url;
  FreeOnTerminate := False; //True;
  inherited Create(CreateSuspended);
end;



А есть вроде-бы более "продвинутый " но он не работает даже режиме создания списка MT_Mode_List
Причем если запускать код потока последовательно все работает как надо .
(Сейчас код переусложнен разными костями но и в более простом варианте он всеравно не функциклирует )
Файловая загрузка работает как часы, а загрузка из сети "густит и вянет" .

Код: Выделить всё

  TImgLoadingThread = class(TThread)
  private
  protected

    procedure Execute; override;
    procedure Load;
    procedure Sync;
    procedure Sync0;
   public

    b1: TBitmap;
    sx,sy,Ind: integer;
    FLoad:Boolean;
    MT_Mode_2:Integer;
    FileName,URL,NetName : string;
   UPDATE  :Boolean;

  end;
procedure TImgLoadingThread.Load;
Const im: TPicture= Nil;
var
  bmp: TBitmap;
  img: TPicture;
  st:TMemoryStream;
Procedure Case_MT;
begin
Case  MT_Mode_2 of
  MT_Mode_Norm:Synchronize(Sync);
  MT_Mode_NoMt:Sync;
  MT_Mode_List:TP_List.Add(B1);
end;
end;

BEGIN

TC:=TC+1;
if netMode then begin

FLoad:= (b1=Nil);

If  FLoad then begin
b1 := TBitmap.Create;
//bmp:=NetLoadBMP_PHP(URL,sx,sy);
if im=nil then IM:= TPicture.Create;
st:=TMemoryStream.Create;
httpclient.IOTimeout:=300;
try

    httpclient.Get(URL,St);
    if st <> Nil then begin
    St.Seek(0, soFromBeginning);
    Im.LoadFromStream(ST);
    Im.Bitmap.Modified:=True;

   end;

  except
  St.Free;
  If MT_Mode_2=MT_Mode_List then  TP_List.Add(Nil);
  b1.Free;
  Exit;
  end;
St.Free;

b1.Width := Sx; b1.Height := Sy;
b1.Canvas.StretchDraw(Rect(0, 0, Sx, Sy),Im.Bitmap);

Case_MT;
if MT_Mode_2<>MT_Mode_List then b1.Free;
end
   else begin
    Case_MT; if MT_Mode_2<>MT_Mode_List then
    if not  FLoad then
    b1.Free;
   end;
exit;
end;
// Для загрузки файлов
While TC-LC >5 do ;
   b1 := TBitmap.Create;
   img := TPicture.Create;
     try
       img.LoadFromFile(Dir+FileName);
       b1.Width := Sx; b1.Height := Sy;
       b1.Canvas.StretchDraw(Rect(0, 0, Sx, Sy),img.Bitmap);
    FLoad:=False;
     Case_MT;

     finally
   if MT_Mode_2<>MT_Mode_List then b1.Free;
   img.Free;
end;
  end;

  procedure TImgLoadingThread.Sync0;
  begin
    Sleep(10);

  end;

procedure TImgLoadingThread.Execute;
begin
while (not Terminated) do
If  UPDATE then begin
Synchronize(Sync0);
Load;
UPDATE  :=False;
Terminate;
end;
end;


procedure TImgLoadingThread.Sync;
begin
If TC<>CC THEN F_GalPic.StatusBar1.SimpleText:='Загузка картинок ...'
ELSE F_GalPic.StatusBar1.SimpleText:='Ok';
F_GalPic.Label2.Caption:=Format ('TC=%d',[TC] );


if not FLoad  then
F_GalPic.ImageList1.Add(b1, nil) else
  F_GalPic.ImageList1.Replace(Ind,b1, nil);
  if  FLoad  then begin
  exit; end;
  with F_GalPic.ListView1.Items.Add do
  begin
  if netMode then Caption := NetName else
    Caption := FileName;
    ImageIndex := F_GalPic.ListView1.Items.Count-1;
  end;
  F_GalPic.image2.Picture.Assign(B1);
end;



(Потоки запускаю из под таймера по пять штук и добавляю только если они уже обработаны )

[WAYFARER]

Alex2013а в чем именно проблема заключается?

Причем если запускать код потока последовательно все работает как надо .

Во втором варианте не увидел - ты же для каждого потока создаешь свой экземпляр THttpSend, да?

[Alex2013]

Alex2013а в чем именно проблема заключается?

Причем если запускать код потока последовательно все работает как надо .

Во втором варианте не увидел - ты же для каждого потока создаешь свой экземпляр THttpSend, да?

Упс! Спасибо! Это я точно упустил из виду ... Но там и вариант с bmp:=NetLoadBMP_PHP(URL,sx,sy); глючит аналогично, а там httpclient точно отдельный.
Сейчас врезал из программы первый вариант и заставил работать в простом примере где капитально вник во все коллизии.

Главный прикол в том что там "тихой сапой" перегружает уже существующий TImage и это обходит запрет на изменение визуального элемента из потока.(Как это воспроизвести при работе со связкой TListView + TImageList ума не приложу . ) А проблемы и непонятки как выяснилось были в чистке списка потоков.


TNetLoad01.7z Размер: 3,1 МБ
( Проект изначально под виндовс но можно проверить и в других ос, компилировать только для 32 бит (при компиляции для 64-х бит нет доступа в сеть ) ОС может быть какая угодно .

Зы
Я в курсе что "Очистка списка потоков" у меня сейчас лишняя так как на входе в процедуру стоит "If not T_End then exit;" но это так сказать "задел на будущее" (В это версии примера "Очистка списка потоков" все равно не работает, потому что при очистке галереи нужно следит за состоянием потоков и не освобождать загружаемый TImage по Free ).
Зы Зы
Код модуля галереи в этом примере эдакое многократно переписываемое "чудовище Франкенштейна " используемое в разных тестовых проектах и к саму примеру отношения не имеет.

Добавлено спустя 1 час 19 минут 48 секунд:

Alex2013а в чем именно проблема заключается?

Проблема в том что нужно быстро и желательно в фоновом режиме загружать от десятков до сотен миниатюр из интернета и при этом зносить все это в галерею созданную на основе связки TListView + TImageList .... И вот тут и возникает туча неприятностей и не понятностей. Я просто надеялся на то что у кого нибудь есть ссылка на готовый и надежный пример многопроточной загрузки изображений из интернета .

Добавлено спустя 8 часов 15 минут 31 секунду:
Типа оптимизация и "обнадеживание" ....
Сейчас там явно куча лишнего кода, но как ни пытался повестить это чудовище не так и смог.
Добавлен обычный таймер (object Timer1: TTimer Enabled = False Interval = 100 OnTimer = Timer1Timer)
+ читает массив, а тестовая галерея только для показа
(Достаточно заменить строку IM:=Form2.AddPic(ListBox1.Items[I],b); на IM:=Timage.Create(Nil);IM.Assign(B); и выбросить фрагменты с комментарием "//Только для этого теста" и ее можно выбросить из проекта )
Патч к примеру...

Код: Выделить всё

procedure TLoadPicThread.Load;
Var
B:TBitmap;
begin
try
   B:=RE_NetLoadBMP_PHP(fURL);
   if Not  FreeOnTerminate then begin
   if b.Modified then fIm.Picture.Bitmap.Assign(B);
  fIm.Picture.Bitmap.Modified:=b.Modified;
  end;
  B.Free;
  except
end;
end;

procedure  TLoadPicThread.Execute;
Var
B:TBitmap;
begin
while (not Terminated) do
If  UPDATE then begin
Synchronize(@SLoad);
Load;
T_List[Find]:=nil;
T_UPDATE:=T_UPDATE+1;
if  not  T_End then
T_End:=T_Count = T_UPDATE;
UPDATE  :=False;
FreeOnTerminate :=  True;
Terminate;
end;
end;

procedure TMform.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled:=False;
Button2Click(Sender);
Sleep(10);
end;

procedure TMform.Button1Click(Sender: TObject);
Var
IM:Timage;
I:Integer;
sIm:TList;
T:TLoadPicThread;
Const B:TBitmap=Nil;
      IM_List:TList=Nil;
      F:Boolean=False;
      FC:Boolean=False;
begin
if Timer1.Enabled or f or not T_end then Begin
Timer1.Enabled:=True;
exit;
end;

//Только для этого теста
If Form2.GetControlIndex(Form2.ScrollBox1)=-1 then
Form2.InsertControl(Form2.ScrollBox1);
//---------------------
F:=True;

FC:=False;


MForm.StatusBar1.SimpleText:=
Format(' %d ',[T_COUNT]);

If b = nil then begin
b:=TBitmap.Create;
b.SetSize(Unit2.ImW,Unit2.ImH);
b.Canvas.Pen.Color:=clRed;
b.Canvas.Line (0,0, Unit2.ImW-1,Unit2.ImH-1);
b.Canvas.Frame(0,0, Unit2.ImW-1,Unit2.ImH-1);
b.Modified:=False;
end;
// Очистка списка картинок  ---------------------
if IM_List=Nil then IM_List:=TList.Create;

//Только для этого теста
If Form2.GetControlIndex(Form2.ScrollBox1)<>-1 then
Form2.RemoveControl(Form2.ScrollBox1);
if Unit2.ILst<>Nil then begin
For I:=0 to Unit2.ILst.Count-1 do
Form2.ScrollBox1.RemoveControl(TImage(Unit2.ILst[i]));
sIm:=Unit2.ILst;Unit2.ILst:=TList.Create;sIm.Free;
end;
//----------------------

// Очистка списка потоков ---------------------
if T_List=Nil then T_List:=TList.Create;
If (T_List.Count>0) then
  For I:=0 to T_List.Count-1 do
  If T_List[i]<>nil then
      begin
       TLoadPicThread(T_List[i]).FreeOnTerminate:=True;
       TLoadPicThread(T_List[i]).Terminate;
     end;

T_List.Clear;
///Основная очистка
For I:=0 to IM_List.Count-1 do
begin
Timage(IM_List[i]).Free;;
End;

IM_List.Clear;

//-----------------------

T_Count:=ListBox1.Count;
T_UPDATE:=0; T_End:=True;

FC:=True;

For I:=0 to ListBox1.Count-1 do
begin
MForm.StatusBar1.SimpleText:=
Format('Загрузка картинок найдено %d ',[I+1]);
// IM:=Timage.Create(Nil);
IM:=Form2.AddPic(ListBox1.Items[I],b);
end;


For I:=0 to ListBox1.Count-1 do
begin

MForm.StatusBar1.SimpleText:=
Format('Загрузка картинкок найдено %d ',[I+1]);

IM:=  TImage(Unit2.ILst[i]);"//Только для этого теста"

Im_List.Add(Im);

T:=TLoadPicThread.Create(True,Memo1.Lines[I], Im,I );
T.UPDATE:=True;
T_List.Add(T);
//T.Execute;
Sleep(5);
End;


FC:=False; Sleep(10);

if not FC Then
For I:=0 to ListBox1.Count-1 do if not FC Then
TLoadPicThread(T_List[I]).Resume;

//Только для этого теста
If Form2.GetControlIndex(Form2.ScrollBox1)=-1 then
Form2.InsertControl(Form2.ScrollBox1);
//======================

F:=False;
end;


Добавлено спустя 11 часов 2 минуты 1 секунду:
"Самообман страшная штука" Увы неожиданно оказалась, что все это безобразие все-же капитально виснет при отсутствии доступа в сеть. Видимо куча потоков тупо "дидосит" открытие сокетов...( В нормальном случае сокеты "не толпятся" слишком сильно )
(В базовом проекте, запуск загрузки галереи при отсутствии доступа в сеть почти исключен, бо вначале читается список миниатюр, а там есть более мнение надежная "ловушка исключений", но все равно не хорошо рассчитывать, что "все всегда будет хорошо" . )

Добавлено спустя 1 час 55 минут 1 секунду:
Ну вот теперь что-то как-бы работает и со связкой TListView + TImageList но в "ручном режиме" (По кнопке "тест" ) вообщем видимо придется "освежать" TImageList "по таймеру".
(Иначе теряется весь эффект "Ленивой загрузки" то есть если я нажимаю на кнопку Load 1 или Load 2 то загрузка старой галереи происходит псевдо-мгновенно, а потом уже потоки незаметно "догружают" то что подтормаживает )
Зы
На скрине я специально поймал момент неполной загрузки .