Прогрессбар и поток - Общие вопросы Delphi

Aqel · 09.10.2017, 19:55

Привет, не могу решить как подключить прогрессбар к потоку, вот код:

Код:

Function GEt_(Url:String): String;                    // Загрузка WEB в память
var
  mStream: TMemoryStream;
  IdHTTP1: TIdHTTP;
  Lst: TStrings;
begin
  Result:= '';
  mStream:= TMemoryStream.Create;
  Lst:= TStringList.Create;
  try
    IdHTTP1:= TIdHTTP.Create(nil);
  { тут следует "настроить" параметры idHTTP }
    IdHTTP1.Request.Host:='mods.curse.com';
    IdHTTP1.HandleRedirects:= True;
    IdHTTP1.Request.Connection:='keep-alive';
    IdHTTP1.Request.Accept:='text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 ';
    IdHTTP1.Request.UserAgent:='Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.102 Safari/537.36';
    IdHTTP1.Request.ContentType:='application/x-www-form-urlencoded';
    IdHTTP1.Request.AcceptLanguage:='ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3';
    try
      IdHTTP1.Get(URL, mStream);
      mStream.Position:= 0;
      Lst.LoadFromStream(mStream);
      Result:= Lst.Text; 
    finally
      IdHTTP1.Free;
    end;
  finally
    mStream.Free;
    Lst.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  l, l0, l1, l2: string;
begin
  ini:= TIniFile.Create(ExtractFilePath(Application.ExeName) + si);
  url:= ini.ReadString('URL', IntToStr(StringGrid1.Row), '');
  Label2.Caption:= url;
  l1:= Copy(GEt_(url), pos(up, GEt_(url)) + 39, length(GEt_(url)));
  l0:= Copy(l1, 1, pos('</li>', l1) - 8);
  //Label1.Caption:= l0;
  if l0 = 'Supports:' then
  begin
    l1:= Copy(GEt_(url), pos(up, GEt_(url)) + 49, length(GEt_(url)));    
    l2:= Copy(l1, 1, pos('</li>', l1) - 1);
  end
  else
  begin
    l1:= Copy(GEt_(url), pos(out, GEt_(url)) + 50, length(GEt_(url)));
    l2:= Copy(l1, 1, pos('</li>', l1) - 1);
  end;

Функция GEt_ загружает в память WEB страницу, далее по кнопке копируется нужное слово из памяти (переменные l, l0, l1, l2 - скорость медленная, но больше пока не допетрил как оптимизировать, главное работает.), как "припаять" прогрессбар? Полазил по разным форумам ничего не понял...

(

Aliens_wolfs · 09.10.2017, 21:09

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

Чтобы работал прогрессбар в вашем коде нужно сделать следующее

Код:

type
  TForm1 = class(TForm)
...........................................
  private
    { Private declarations }
  public
    { public declarations }
//Объявляем функции в теле формы в которых будет работать прогрессбар 
  procedure IdHTTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
  procedure IdHTTPWork(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
  procedure IdHTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
//Подробно прописываем функции в которых будет работать прогрессбар
procedure TForm1.IdHTTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  ProgressBar1.Position := 0;
  ProgressBar1.Max := AWorkcountMax;
end;

procedure TForm1.IdHTTPWork(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
  ProgressBar1.Position := AWorkCount;
end;

procedure TForm1.IdHTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  ProgressBar1.Position := 0;
end;

//Ваш код
Function GEt_(Url:String): String;                    // Загрузка WEB в память
var
  mStream: TMemoryStream;
  IdHTTP1: TIdHTTP;
  Lst: TStrings;
begin
  Result:= '';
  mStream:= TMemoryStream.Create;
  Lst:= TStringList.Create;
  try
    IdHTTP1:= TIdHTTP.Create(nil);
  { тут следует "настроить" параметры idHTTP }
    IdHTTP1.Request.Host:='mods.curse.com';
    IdHTTP1.HandleRedirects:= True;
    IdHTTP1.Request.Connection:='keep-alive';
    IdHTTP1.Request.Accept:='text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 ';
    IdHTTP1.Request.UserAgent:='Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.102 Safari/537.36';
    IdHTTP1.Request.ContentType:='application/x-www-form-urlencoded';
    IdHTTP1.Request.AcceptLanguage:='ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3';

//Указываем функции для IdHTTP1 в которых будет работать прогрессбар
    IdHTTP1.OnWork:= Form1.IdHTTPWork;
    IdHTTP1.OnWorkBegin:= Form1.IdHTTPWorkBegin;
    IdHTTP1.OnWorkEnd:= Form1.IdHTTPWorkEnd;
    try
      IdHTTP1.Get(URL, mStream);
      mStream.Position:= 0;
      Lst.LoadFromStream(mStream);
      Result:= Lst.Text; 
    finally
      IdHTTP1.Free;
    end;
  finally
    mStream.Free;
    Lst.Free;
  end;
end;

Если функция Function GEt_(Url:String): String; находиться в другом модуле то пропишите модуль основной формы в этом модуле

Aqel · 10.10.2017, 05:52

Цитата:

Сообщение от Aliens_wolfs

...
Если функция Function GEt_(Url:String): String; находиться в другом модуле то пропишите модуль основной формы в этом модуле

Выдало ошибку: [dcc32 Error] Unit1.pas (97): E2009 Несовместимые типы: «Списки параметров различаются»
Ошибка пала на:
IdHTTP1.OnWork:= Form1.IdHTTPWork;
IdHTTP1.OnWorkBegin:= Form1.IdHTTPWorkBegin;
IdHTTP1.OnWorkEnd:= Form1.IdHTTPWorkEnd;

.OnWork = int64 а .IdHTTPWork = integer...

Поставил int64 в функциях - такая же ошибка...

Aliens_wolfs · 10.10.2017, 15:00

Я проверял у меня работает, что за Delphi у вас, проверти эти параметры в модуле
IdHTTP1, киньте его на форму и посмотрите в events эти свойства, возможно у вас версия другая, да и вообще объявляли ли вы их в теле Forms ?
Либо проект выложите, здесь его и проверим, возможно что то делаете не так

Aqel · 10.10.2017, 15:07

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, ValEdit, ComCtrls, DBCtrls, Vcl.CheckLst, UrlMon, MSHTML, activex,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, StrUtils, Clipbrd, IniFiles,
  Vcl.OleCtrls, SHDocVw, IdAntiFreezeBase, Vcl.IdAntiFreeze, ShellAPI;

const
  up = '<li class="version version-up-to-date">';
  out = '<li class="version version-out-of-date">';
  
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button3: TButton;
    Button4: TButton;
    Button2: TButton;
    Button5: TButton;
    Button6: TButton;
    IdHTTP1: TIdHTTP;
    StringGrid1: TStringGrid;
    Label2: TLabel;
    IdAntiFreeze1: TIdAntiFreeze;
    grp1: TGroupBox;
    grp2: TGroupBox;
    pb1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Label2Click(Sender: TObject);
 
  private
    { Private declarations }
  public
    { Public declarations }
    //Объявляем функции в теле формы в которых будет работать прогрессбар
  procedure IdHTTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: integer);
  procedure IdHTTPWork(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: integer);
  procedure IdHTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
  end;

Delphi XE8 SP1

... УПСС! Я просто скопировал функции,а не добавил в TIdHTTP... Сделаю как надо и отпишусь (хотя думаю - всё будет робить.)...

Aqel · 10.10.2017, 15:21

Нет, всё та же ошибка:
[dcc32 Error] Unit1.pas(83): E2009 Incompatible types: 'Parameter lists differ'

У меня Delphi так "прописала":

Код:

procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  pb1.Position:= AWorkCount;
end;

procedure TForm1.IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  pb1.Position:= 0;
  pb1.Max:= AWorkcountMax
end;

Aqel · 10.10.2017, 15:22

ООО! Работает, но прогрессбар не показывает ничего...

Aliens_wolfs · 11.10.2017, 10:44

Да странно почему то в XE AWorkCount всегда 0 выдает в D7 все нормально, запрос тогда нужно делать на размер принятия данных в ContentLength

Aqel · 11.10.2017, 11:31

Цитата:

Сообщение от Aliens_wolfs

Да странно почему то в XE AWorkCount всегда 0 выдает в D7 все нормально, запрос тогда нужно делать на размер принятия данных в ContentLength

Это где?

Aliens_wolfs · 12.10.2017, 14:54

Да уж какие то странности в работе с TIdHTTP в XE. Там даже в заголовке ответа сервера нет Content-Length а в снифере есть и AWorkcountMax всегда 0 а в D7 все нормально AWorkcountMax равен размеру ресурса

вот для теста на вашем коде

Код:

procedure TForm1.IdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  ProgressBar1.Position := AWorkCount;
end;

procedure TForm1.IdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  ProgressBar1.Position := 0;
  ProgressBar1.Max := AWorkcountMax;
//.Extract('Content-Length', Memo2.Lines);
 Memo2.Text:= TIdHTTP(ASender).Response.RawHeaders.text;
end;

procedure TForm1.IdHTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
  ProgressBar1.Position := 0;
end;


//Ваш код
Function GEt_(Url:String): String;                    // Загрузка WEB в память
var
  mStream: TMemoryStream;
  IdHTTP1: TIdHTTP;
  Lst: TStrings;
begin
  Result:= '';
  mStream:= TMemoryStream.Create;
  Lst:= TStringList.Create;
  try
    IdHTTP1:= TIdHTTP.Create(nil);
   // IdHTTP1.ConnectTimeout := 30000;
   //IdHTTP1.ReadTimeout := 30000;
  { тут следует "настроить" параметры idHTTP }
   // IdHTTP1.Request.Host:='mods.curse.com';
    IdHTTP1.HandleRedirects:= True;
    IdHTTP1.Request.Connection:= 'keep-alive';
    IdHTTP1.Request.Accept:= 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
    IdHTTP1.Request.AcceptEncoding:= 'gzip';
    IdHTTP1.Request.UserAgent:= 'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/37.0.2062.102 Safari/537.36';
    IdHTTP1.Request.ContentType:= 'application/x-www-form-urlencoded';
    IdHTTP1.Request.AcceptLanguage:= 'ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3';

//Указываем функции для IdHTTP1 в которых будет работать прогрессбар
    IdHTTP1.OnWork:= Form1.IdHTTPWork;
    IdHTTP1.OnWorkBegin:= Form1.IdHTTPWorkBegin;
    IdHTTP1.OnWorkEnd:= Form1.IdHTTPWorkEnd;
    try
      IdHTTP1.Get(URL, mStream);
      mStream.Position:= 0;
      Lst.LoadFromStream(mStream);
      Result:= Lst.Text;
    finally
      IdHTTP1.Free;
    end;
  finally
    mStream.Free;
    Lst.Free;
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Text:= GEt_('http://www.programmersforum.ru/showthread.php?t=312995');
end;

Ответ в сниффере

Цитата:

HTTP/1.1 200 OK
Date: Thu, 12 Oct 2017 12:00:48 GMT
Server: Apache
X-Powered-By: PHP/5.4.17
Set-Cookie: bblastvisit=1507809648; expires=Fri, 12-Oct-2018 12:00:48 GMT; path=/; domain=.programmersforum.ru
Set-Cookie: bblastactivity=0; expires=Fri, 12-Oct-2018 12:00:48 GMT; path=/; domain=.programmersforum.ru
Expires: 0
Cache-Control: private, post-check=0, pre-check=0, max-age=0
Pragma: no-cache
X-UA-Compatible: IE=7
Content-Encoding: gzip
Content-Length: 19176
Keep-Alive: timeout=5, max=100
Connection: Keep-Alive
Content-Type: text/html; charset=windows-1251

Ответ в XE IdHTTP в MEMO

Цитата:

Date: Thu, 12 Oct 2017 12:00:48 GMT
Server: Apache
X-Powered-By: PHP/5.4.17
Set-Cookie: bblastvisit=1507809648; expires=Fri, 12-Oct-2018 12:00:48 GMT; path=/; domain=.programmersforum.ru
Set-Cookie: bblastactivity=0; expires=Fri, 12-Oct-2018 12:00:48 GMT; path=/; domain=.programmersforum.ru
Expires: 0
Cache-Control: private, post-check=0, pre-check=0, max-age=0
Pragma: no-cache
X-UA-Compatible: IE=7
Keep-Alive: timeout=5, max=100
Connection: Keep-Alive
Content-Type: text/html; charset=windows-1251
Transfer-Encoding: chunked

Куда IdHTTP для XE прячет строку Content-Length неизвестно да и главное зачем в D7 такой проблемы ненаблюдается

10.10.2017, 15:00	#4
Aliens_wolfs Форумчанин Регистрация: 16.12.2009 Сообщений: 902	Я проверял у меня работает, что за Delphi у вас, проверти эти параметры в модуле IdHTTP1, киньте его на форму и посмотрите в events эти свойства, возможно у вас версия другая, да и вообще объявляли ли вы их в теле Forms ? Либо проект выложите, здесь его и проверим, возможно что то делаете не так Последний раз редактировалось Aliens_wolfs; 10.10.2017 в 15:03.

10.10.2017, 15:21	#6
Aqel Пользователь Регистрация: 07.05.2011 Сообщений: 24	Нет, всё та же ошибка: [dcc32 Error] Unit1.pas(83): E2009 Incompatible types: 'Parameter lists differ' У меня Delphi так "прописала": Код: `procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64); begin pb1.Position:= AWorkCount; end; procedure TForm1.IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64); begin pb1.Position:= 0; pb1.Max:= AWorkcountMax end;` Всё намного проще, чем есть на самом деле...

10.10.2017, 15:22	#7
Aqel Пользователь Регистрация: 07.05.2011 Сообщений: 24	ООО! Работает, но прогрессбар не показывает ничего... Всё намного проще, чем есть на самом деле... Последний раз редактировалось Aqel; 10.10.2017 в 15:43.

11.10.2017, 10:44	#8
Aliens_wolfs Форумчанин Регистрация: 16.12.2009 Сообщений: 902	Да странно почему то в XE AWorkCount всегда 0 выдает в D7 все нормально, запрос тогда нужно делать на размер принятия данных в ContentLength Последний раз редактировалось Aliens_wolfs; 11.10.2017 в 10:47.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Прогрессбар	bmp152	Компоненты Delphi	7	16.06.2013 23:50
Поток. Не получается создать поток. Выдает ошибки при запуске	bigory	Общие вопросы по Java, Java SE, Kotlin	3	23.09.2010 00:40
Добавить прогрессбар к потоку(поток в отдельном модуле, без формы)	Человек_Борща	Общие вопросы Delphi	2	21.05.2010 22:00
Прогрессбар...	Лёка	Общие вопросы Delphi	12	18.03.2010 14:41
помогите приделать прогрессбар.	Mobile™	Общие вопросы Delphi	43	20.10.2009 11:10