Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 09.10.2017, 19:55   #1
Aqel
Пользователь
 
Аватар для Aqel
 
Регистрация: 07.05.2011
Сообщений: 24
Вопрос Прогрессбар и поток

Привет, не могу решить как подключить прогрессбар к потоку, вот код:
Код:
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 - скорость медленная, но больше пока не допетрил как оптимизировать, главное работает.), как "припаять" прогрессбар? Полазил по разным форумам ничего не понял... (
Всё намного проще, чем есть на самом деле...
Aqel вне форума Ответить с цитированием
Старый 09.10.2017, 21:09   #2
Aliens_wolfs
Форумчанин
 
Регистрация: 16.12.2009
Сообщений: 902
По умолчанию

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

Чтобы работал прогрессбар в вашем коде нужно сделать следующее
Код:
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; находиться в другом модуле то пропишите модуль основной формы в этом модуле

Последний раз редактировалось Aliens_wolfs; 09.10.2017 в 21:45.
Aliens_wolfs вне форума Ответить с цитированием
Старый 10.10.2017, 05:52   #3
Aqel
Пользователь
 
Аватар для Aqel
 
Регистрация: 07.05.2011
Сообщений: 24
По умолчанию

Цитата:
Сообщение от 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 в функциях - такая же ошибка...
Всё намного проще, чем есть на самом деле...

Последний раз редактировалось Aqel; 10.10.2017 в 06:11.
Aqel вне форума Ответить с цитированием
Старый 10.10.2017, 15:00   #4
Aliens_wolfs
Форумчанин
 
Регистрация: 16.12.2009
Сообщений: 902
По умолчанию

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

Последний раз редактировалось Aliens_wolfs; 10.10.2017 в 15:03.
Aliens_wolfs вне форума Ответить с цитированием
Старый 10.10.2017, 15:07   #5
Aqel
Пользователь
 
Аватар для Aqel
 
Регистрация: 07.05.2011
Сообщений: 24
По умолчанию

Код:
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:10.
Aqel вне форума Ответить с цитированием
Старый 10.10.2017, 15:21   #6
Aqel
Пользователь
 
Аватар для 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;
Всё намного проще, чем есть на самом деле...
Aqel вне форума Ответить с цитированием
Старый 10.10.2017, 15:22   #7
Aqel
Пользователь
 
Аватар для Aqel
 
Регистрация: 07.05.2011
Сообщений: 24
По умолчанию

ООО! Работает, но прогрессбар не показывает ничего...
Всё намного проще, чем есть на самом деле...

Последний раз редактировалось Aqel; 10.10.2017 в 15:43.
Aqel вне форума Ответить с цитированием
Старый 11.10.2017, 10:44   #8
Aliens_wolfs
Форумчанин
 
Регистрация: 16.12.2009
Сообщений: 902
По умолчанию

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

Последний раз редактировалось Aliens_wolfs; 11.10.2017 в 10:47.
Aliens_wolfs вне форума Ответить с цитированием
Старый 11.10.2017, 11:31   #9
Aqel
Пользователь
 
Аватар для Aqel
 
Регистрация: 07.05.2011
Сообщений: 24
По умолчанию

Цитата:
Сообщение от Aliens_wolfs Посмотреть сообщение
Да странно почему то в XE AWorkCount всегда 0 выдает в D7 все нормально, запрос тогда нужно делать на размер принятия данных в ContentLength
Это где?
Всё намного проще, чем есть на самом деле...
Aqel вне форума Ответить с цитированием
Старый 12.10.2017, 14:54   #10
Aliens_wolfs
Форумчанин
 
Регистрация: 16.12.2009
Сообщений: 902
По умолчанию

Да уж какие то странности в работе с 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 такой проблемы ненаблюдается

Последний раз редактировалось Aliens_wolfs; 12.10.2017 в 15:05.
Aliens_wolfs вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Прогрессбар 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