На главную
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! ПРАВИЛА РАЗДЕЛА · FAQ раздела Delphi · Книги по Delphi
Пожалуйста, выделяйте текст программы тегом [сode=pas] ... [/сode]. Для этого используйте кнопку [code=pas] в форме ответа или комбобокс, если нужно вставить код на языке, отличном от Дельфи/Паскаля.
Следующие вопросы задаются очень часто, подробно разобраны в FAQ и, поэтому, будут безжалостно удаляться:
1. Преобразовать переменную типа String в тип PChar (PAnsiChar)
2. Как "свернуть" программу в трей.
3. Как "скрыться" от Ctrl + Alt + Del (заблокировать их и т.п.)
4. Как прочитать список файлов, поддиректорий в директории?
5. Как запустить программу/файл?
... (продолжение следует) ...

Вопросы, подробно описанные во встроенной справочной системе Delphi, не несут полезной тематической нагрузки, поэтому будут удаляться.
Запрещается создавать темы с просьбой выполнить какую-то работу за автора темы. Форум является средством общения и общего поиска решения. Вашу работу за Вас никто выполнять не будет.


Внимание
Попытки открытия обсуждений реализации вредоносного ПО, включая различные интерпретации спам-ботов, наказывается предупреждением на 30 дней.
Повторная попытка - 60 дней. Последующие попытки бан.
Мат в разделе - бан на три месяца...
Модераторы: jack128, D[u]fa, Shaggy, Rouse_
  
> Потоки + Idhttp
    Добрый вечер.
    Как работать с 1 потоком я вроде разобрался, теперь хочу понять как работать с многопоточностью.

    Подскажите плиз как реализовать многопоточность,потоков 10 для данного примера:
    (Программа должна в 10 потоках грузить разные странички)


    unit1:
    ExpandedWrap disabled
      procedure TForm1.Button1Click(Sender: TObject);
      var
        NewThread: TNewThread;
      begin
        NewThread:=TNewThread.Create(true);
        NewThread.FreeOnTerminate:=true;
        NewThread.Priority:=tpLower;
        NewThread.Resume;
      end;


    Unit2:
    ExpandedWrap disabled
      TNewThread = class(TThread)
        private
          Progress: integer;
      Otvet: TStringList;
          procedure SetProgress;
       
        protected
          procedure Execute; override;
        end;
      ...
       
      procedure TNewThread.Execute;
      var
        i: integer;
       idHTTP1:TidHTTP;
       IdCookieManager1: TIdCookieManager;
       
      begin
       IdCookieManager1:= TIdCookieManager.Create(nil);
      idHTTP1 := TidHTTP.Create(nil);
      IdHTTP1.AllowCookies:=true;
      IdHTTP1.CookieManager:= IdCookieManager1;
      IdHTTP1.HandleRedirects:= true;
       
      Otvet:= TStringList.Create;
          Synchronize(SetProgress);
        end;
       
       
      procedure TNewThread.SetProgress;
      begin
      Otvet.Text:=IdHTTP1.Get('http://www.ya.ru');
      end;
    Сообщение отредактировано: Анчоус -
      Один поток работает? Теперь просто запусти 10 потоков.
        если бы я знал как это сделать я бы не спрашивал тут.
        может у кого-нибудь есть пример где много потоков используется.
        не могу понять как их создавать
          Цитата Anatoly Podgoretsky @
          Один поток работает? Теперь просто запусти 10 потоков.


          Один поток у автора тоже неправильно реализован.

          Анчоус

          IdHTTP
          Все фотографии-обои Виталия Невзорова одним файлом. 3Гб.
          http://www.almar.su/nevzorov/photo.zip
          Если с вопросами все будут посылать в гугль - откуда в нём возьмутся ответы?
            ExpandedWrap disabled
              var
                NewThread: TNewThread;
                NewThread1: TNewThread;
                NewThread2: TNewThread;
              begin
                NewThread:=TNewThread.Create(true);
                NewThread.FreeOnTerminate:=true;
                NewThread.Priority:=tpLower;
                NewThread.Resume;
                NewThread1:=TNewThread.Create(true);
                NewThread1.FreeOnTerminate:=true;
                NewThread1.Priority:=tpLower;
                NewThread1.Resume;
                NewThread2:=TNewThread.Create(true);
                NewThread2.FreeOnTerminate:=true;
                NewThread2.Priority:=tpLower;
                NewThread2.Resume;
              end;

            100 % не гарантирую но думаю вот так заработает.
            В тюрьме столько не сидят, сколько вы в интернете…
            Жизнь, как туалетная бумага... длинная, а тратишь на всякое дерьмо...
              Цитата Демо @

              то ,что надо...
              Не мог бы помочь разбраться с ошибкой:
              [Error] uGetHttpThread.pas(185): Incompatible types: 'TIdBytes' and 'Int64'
              [Error] uGetHttpThread.pas(186): Incompatible types: 'TIdBytes' and 'Int64'

              прочитал пост: IdHTTP (сообщение #2311934) - не помогло.
              Сообщение отредактировано: Анчоус -

              Прикреплённый файлПрикреплённый файлindy_Download.zip (24.75 Кбайт, скачиваний: 113)
                Анчоус

                Исправь в описаниях функций типы.

                ExpandedWrap disabled
                      procedure FHWork(ASender: TObject; AWorkMode: TWorkMode;
                        AWorkCount: Int64);
                      procedure FLReceive(ASender: TIdConnectionIntercept;
                        var ABuffer: TBytes);
                      procedure FLSend(ASender: TIdConnectionIntercept;
                        var ABuffer: TBytes);


                Ну и в секции реализации такие же параметры должны быть.
                Все фотографии-обои Виталия Невзорова одним файлом. 3Гб.
                http://www.almar.su/nevzorov/photo.zip
                Если с вопросами все будут посылать в гугль - откуда в нём возьмутся ответы?
                  поменять все TBytes на Int64 ?

                  полюбому ошибка в:
                  FL.OnReceive := FLReceive;
                  FL.OnSend := FLSend;

                  [Error] uGetHttpThread.pas(172): Incompatible types: 'TIdBytes' and 'Int64'



                  или заменив на то что выше?




                  procedure FHWork(ASender: TObject; AWorkMode: TWorkMode;
                  AWorkCount: Int64);
                  procedure FLReceive(ASender: TIdConnectionIntercept;
                  var ABuffer: TBytes);
                  procedure FLSend(ASender: TIdConnectionIntercept;
                  var ABuffer: TBytes);

                  теперь ругается на
                  procedure FLReceive(ASender: TIdConnectionIntercept;
                  var ABuffer: TBytes);


                  я в этом не очень пока понимаю,не могли бы сделать готовы пример?плиз)
                  просто на примере легче учиться и разбираться
                  Сообщение отредактировано: Анчоус -
                    ExpandedWrap disabled
                          procedure FHWork(ASender: TObject; AWorkMode: TWorkMode;
                            AWorkCount: Int64);
                          procedure FLReceive(ASender: TIdConnectionIntercept;
                            var ABuffer: TBytes);
                          procedure FLSend(ASender: TIdConnectionIntercept;
                            var ABuffer: TBytes);


                    ExpandedWrap disabled
                      procedure TGetHTTP.FHWork(ASender: TObject; AWorkMode: TWorkMode;
                        AWorkCount: int64);
                       
                      procedure TGetHTTP.FLReceive(ASender: TIdConnectionIntercept;
                        var ABuffer: TBytes);
                       
                      procedure TGetHTTP.FLSend(ASender: TIdConnectionIntercept;
                        var ABuffer: TBytes);
                    Все фотографии-обои Виталия Невзорова одним файлом. 3Гб.
                    http://www.almar.su/nevzorov/photo.zip
                    Если с вопросами все будут посылать в гугль - откуда в нём возьмутся ответы?
                      Приветствую, скачал модуль описанный выше и доработал его немного под D2010, так вот пишу чекер прокси, чекает норм, но, когда остается последних 10 прокси процесс тупо висит, как будто что то жедт, помогите выловить ошибку в модуле или в моем коде его использования:

                      ExpandedWrap disabled
                        {
                        Модуль uGetHTTPThread
                        Выполнение запроса HTTP GET в отдельном потоке с
                        возможностью повторного использования.
                        Ведется учет количества потоков
                         
                        Требования - установленный Indy10
                         
                         (c) Демо
                         
                        Специально для Sources.ru (2005,2008)
                         
                        Пример использования приложен
                        }
                         
                        unit uGetHttpThread;
                         
                        interface
                         
                        uses
                          windows, Messages, classes, SysUtils, idHTTP, idLogDebug, idComponent, idGlobal,IdIOHandler,
                          IdIOHandlerSocket, IdIOHandlerStack,  IdIntercept,idException,IdStackConsts;
                         
                        const
                        //Сообщение для добавления запроса в очередь
                          WM_ADD=WM_USER+1;
                        //Сообщения для инициирования выполнения запроса
                          WM_PROCESS=WM_USER+2;
                         
                        var
                        //Список потоков
                        //  ThrList: TThreadList;
                          ThrList: TThreadList;
                         
                        type
                         
                          TStateHTTPThread=(shNone,shReady,shComplete,shWork);  //Состояние потока
                          TActionHTTPThread=(ahNone,ahFree);  //Действие при обработке OnComplete
                          TGetHTTP=class;
                          TCompleteQuery=procedure(Sender: TGetHTTP;
                            var Action:TActionHTTPThread) of Object;
                          TProgressQuery=procedure(Sender: TGetHTTP;
                            aReadCount,aSendCount: Integer) of Object;
                         
                        //Структура, заполняемая в потоке.
                          THTTPRec=record
                            Query: String;              //Запрос в виде http://url
                            ProxyServer: String;        //Адрес прокси-сервера
                            ProxyPort: Integer;         //Порт прокси-сервера
                            ErrorMsg: String;//String           //Результатт в текстовом виде
                            ErrorCode: Integer;         //Результат в числовом виде
                            RecvStr: AnsiString;//String            //Принятая строка(полностью с заголовком)
                            SendStr: AnsiString;//String            //Отосланная строка
                            CountSend: Integer;         //Количество отосланных байт
                            CountRcv: Integer;          //Количество принятых байт
                            Page: String;               //Возвращенная страница(без заголовка)
                          end;
                         
                        //Прокси-сервер
                          TProxy=record
                            ProxyAddr: String;
                            Port: integer;
                          end;
                         
                        //Структура для передачи сообщений
                          PQProxy=^TQProxy;
                          TQProxy=record
                            Proxy: TProxy;
                            Query: String;
                          end;
                         
                        //Собственно, сам поток
                          TGetHTTP=class(TThread)
                          private
                            FQueryList: TList;            //Очередь запросов
                            FCS: RTL_CRITICAL_SECTION;
                            FH: TidHTTP;
                            FL: TidLogDebug;
                            FS: TIdIOHandlerStack;
                            FConnectionTimeOut: Integer;  //Таймаут ожидания соединения
                            FReadTimeOut: Integer;        //Таймаут получения данных
                            FResult: THTTPRec;
                            FState: TStateHTTPThread;
                            FOnComplete: TCompleteQuery;
                            FOnProgress: TProgressQuery;
                            FWaitHandle: THandle;
                            function GetConnectionTimeOut: Integer;
                            function GetReadTimeOut: Integer;
                            procedure SetConnectionTimeOut(const Value: Integer);
                            procedure SetReadTimeOut(const Value: Integer);
                            function GetQueryCount: Integer;
                            procedure FComplete;
                            procedure FProgress;
                            procedure FHWork(ASender: TObject; AWorkMode: TWorkMode;
                              AWorkCount: Int64);
                            procedure FLReceive(ASender: TIdConnectionIntercept;
                              var ABuffer: TBytes);
                            procedure FLSend(ASender: TIdConnectionIntercept;
                              var ABuffer: TBytes);
                            procedure Lock;
                            procedure Unlock;
                            function GetFResult: THTTPRec;
                            procedure LoadPage;
                          protected
                            procedure Execute; override;
                          public
                            constructor Create;
                            destructor Destroy; override;
                            procedure Free;
                            procedure Release;
                        //добавление в очередь нового запроса
                            procedure Get(const Query: String;const ProxyAddr: String='';
                              ProxyPort: integer=0);
                         
                            property OnComplete: TCompleteQuery read FOnComplete write FOnComplete;
                            property OnProgress: TProgressQuery read FOnProgress write FOnProgress;
                            property Result: THTTPRec read GetFResult;
                            property State: TStateHTTPThread read FState;
                            property ConnectionTimeOut: Integer read GetConnectionTimeOut write SetConnectionTimeOut;
                            property ReadTimeOut: Integer read GetReadTimeOut write SetReadTimeOut;
                            property QueryCount: Integer read GetQueryCount;
                        //    property ProxyServer: TProxy read FProxy write FProxy;
                          end;
                         
                        //Получение максимального количества потоков
                        function GetMaxThreads: Integer;
                         
                        //Установка максимального количества потоков
                        procedure SetMaxThreads(aMaxThreads: Integer=10);
                         
                        //завершение всех потоков и очистка списка
                        procedure TerminateAllThreads;
                         
                        //Завершение конкретного потока
                        procedure ReleaseThread(Thread:TGetHTTP);
                         
                        //Получение количества потоков в списке
                        function CheckCountThreads: Integer;
                         
                        //Получение структуры TProxy по параметрам
                        function proxy(const ProxyAddr: String; ProxyPort: Integer): TProxy;
                         
                        implementation
                        //uses ufMain;
                        var
                        //Максимальное количество потоков - недоступно из других модулей напрямую
                          MaxThreads: Integer;
                         
                        procedure SetTimeOut(Value: Cardinal);
                        var
                          TicksNow: Cardinal;
                        begin
                          TicksNow := GetTickCount;
                          repeat
                            Sleep(100);
                            //Application.ProcessMessages;
                          until GetTickCount - TicksNow >= Value;
                        end;
                         
                        { TGetHTTP }
                         
                        //Получение структуры TProxy по параметрам
                        function proxy(const ProxyAddr: String; ProxyPort: Integer): TProxy;
                        begin
                          Result.ProxyAddr := ProxyAddr;
                          Result.Port := ProxyPort;
                        end;
                         
                        constructor TGetHTTP.Create;
                        begin
                          if CheckCountThreads=GetMaxThreads then raise Exception.Create('Can''t create thread. MaxThreads='+IntToStr(MaxThreads));
                          FQueryList := TList.Create;
                          inherited Create(True);
                          FreeOnTerminate := False;
                          FState := shNone;             //Поток еще не готов принять запрос
                          with ThrList.LockList do      //Добавляем поток в список
                          try
                            Add(Self);
                          finally
                            ThrList.UnlockList;
                          end;
                          ConnectionTimeOut := 10000;             //Таймаут по-умолчанию 10 секунд
                          ReadTimeOut := 10000;             //Таймаут по-умолчанию 10 секунд
                          InitializeCriticalSection(FCS);
                        //Будем дожидаться инициализации параметров в поточной функции
                          FWaitHandle := CreateEvent(nil,True,False,nil);
                          Resume;
                          try
                            if WaitForSingleObject(FWaitHandle,1000)<>WAIT_OBJECT_0 then
                            begin
                              Release;
                              raise Exception.Create('Create object error');
                            end;
                          finally
                            CloseHandle(FWaitHandle);
                          end;
                        end;
                         
                        destructor TGetHTTP.Destroy;
                        begin
                        //Очищаем очередь запросов
                          while FQueryList.Count>0 do
                          begin
                            Dispose(PQProxy(FQueryList[0]));
                            FQuerylist.Delete(0);
                          end;
                         
                          FQueryList.Free;
                          DeleteCriticalSection(FCS);
                          inherited;
                        end;
                         
                        //Получение данных с сервера
                        procedure TGetHTTP.LoadPage;
                        var
                          P: PQProxy;
                        begin
                          if FState<>shReady then Exit;       //Поток не готов к обработке очередного
                                                              //запроса
                          if FQuerylist.Count=0 then Exit;    //Очередь запросов пуста
                         
                         
                            FState := shWork;                 //Поток занят
                            P := FQueryList[0];               //Выбираем первый запрос из очереди
                            FResult.Query := P^.Query;
                            FResult.ProxyServer := P^.Proxy.ProxyAddr;
                            FResult.ProxyPort := P^.Proxy.Port;
                            FResult.ErrorMsg := '';
                            FResult.ErrorCode := 0;
                            FResult.RecvStr := '';
                            FResult.SendStr := '';
                            FResult.CountSend := 0;
                            FResult.CountRcv := 0;
                            FResult.Page := '';
                            Dispose(PQProxy(FQueryList[0]));  //Освобождаем ресурс
                            FQueryList.Delete(0);
                         
                            try
                            //try
                         
                              FH := TidHTTP.Create(nil);
                              FL := TidLogDebug.Create(nil);
                              FS := TIdIOHandlerStack.Create(nil);
                              FH.ConnectTimeout := ConnectionTimeout;
                              FH.ReadTimeout := ReadTimeout;
                              FS.ConnectTimeout := FH.ConnectTimeout ;
                              FS.ReadTimeout := FH.ReadTimeout;
                              FH.HandleRedirects := FALSE;//Default True////////////////////////////////!!!!!!!!!!!!!
                              FH.AllowCookies := FALSE;/////////////////////////////////////////////////!!!!!!!!!!!!!
                              //FL := TidLogDebug.Create(nil);
                              //FS := TIdIOHandlerStack.Create(nil);
                              FS.Intercept := FL;
                              FH.IOHandler := FS;
                              FL.Active := True;
                              FH.OnWork := FHWork;
                              FL.OnReceive := FLReceive;
                              FL.OnSend := FLSend;
                         
                              FH.ProxyParams.ProxyServer := FResult.ProxyServer;
                              FH.ProxyParams.ProxyPort := FResult.ProxyPort;
                            //try
                            try
                              FResult.Page := FH.Get(FResult.Query);
                         
                              FResult.ErrorMsg := FH.ResponseText;
                              FResult.ErrorCode := FH.ResponseCode;
                            except
                              on e: Exception do        //Ошибка при получении данных
                              begin
                                FResult.ErrorMsg := e.Message;
                                FResult.ErrorCode := -1;
                              end;
                            end;
                            //finally/////////////////////////////////////////////////////////////////////!!!!!!!!!!!
                              if FH.Connected then
                              FH.Disconnect;
                              if FS.Connected then
                              FS.Close;
                              FL.Close;
                              FL.Active := FALSE;
                            //end;
                         
                            FState := shComplete;       //Поток закончил выполнение запроса
                            Synchronize(FComplete);     //Сообщаем пользователю
                         
                            finally
                            FH.Free;
                            FS.Free;
                            FL.Free;
                            end;
                         
                            FState := shReady;          //Поток свободен для обработки новых запросов
                        end;
                         
                        procedure TGetHTTP.Execute;
                        var
                          Handles: array[0..0] of THandle;
                          M: TMsg;
                          RC: Cardinal;
                          p: PQProxy;
                        begin
                        //Создаём очередь выборки сообщений
                          PeekMessage(M, 0, 0, 0, PM_NOREMOVE);
                          FState := shReady;
                         
                          SetEvent(FWaitHandle);
                          try
                          repeat
                        //Ожидаем сообщений
                            RC := MsgWaitForMultipleObjects(0, Handles, False, 10, QS_POSTMESSAGE);
                            case RC of
                        //Получено сообщение в очередь выборки сообщений
                              WAIT_OBJECT_0:
                                begin
                                  GetMessage(M,0,0,0);
                                  case M.message of
                                    WM_QUIT:
                                    Terminate;   //Закончить работу потока
                                    WM_ADD:               //добавить запрос в очередь запросов
                                      begin
                                        p := PQProxy(M.wParam);
                                        FQueryList.Add(p);
                                        PostThreadMessage(ThreadId, WM_PROCESS, 0, 0); //Выполнить запрос
                                      end;
                                    WM_PROCESS:
                                    LoadPage; //Получить данные с сервера
                                  end;
                                end;
                        //Новых сообщений не поступало, но очередь запросов надо проверить
                              WAIT_TIMEOUT:
                              PostThreadMessage(ThreadId, WM_PROCESS, 0, 0);
                            end;
                          until Terminated;
                          finally
                            ReleaseThread(Self);          //Удаляем себя из списка потоков
                          end;
                        end;
                         
                        //Запрос выполнен, обрабатываем данные
                        procedure TGetHTTP.FComplete;
                        var
                          Action: TActionHTTPThread;
                        begin
                          Action := ahNone;
                          if Assigned(FOnComplete) then
                          FOnComplete(Self,Action);
                          if Action = ahFree then
                          Release;
                        end;
                         
                        procedure TGetHTTP.FHWork(ASender: TObject; AWorkMode: TWorkMode;
                          AWorkCount: Int64);
                        begin
                        //Увеличиваем соответствующий счетчик
                          Lock;
                          try
                            case AWorkMode of
                              wmRead: FResult.CountRcv := AWorkCount;
                              wmWrite: FResult.CountSend :=AWorkCount;
                            end;
                          finally
                            Unlock;
                          end;
                          Synchronize(FProgress);
                        end;
                         
                        procedure TGetHTTP.FLReceive(ASender: TIdConnectionIntercept;
                          var ABuffer: TBytes);
                        var
                          s: {String}AnsiString;
                        begin
                        //  Добавляем в буфер полученную информацию
                          SetLength(s,Length(ABuffer));
                          Move(ABuffer[0],s[1],Length(ABuffer));
                          FResult.RecvStr := FResult.RecvStr + s;
                        end;
                         
                        procedure TGetHTTP.FLSend(ASender: TIdConnectionIntercept;
                          var ABuffer: TBytes);
                        var
                          s: {String}AnsiString;
                        begin
                        //  Добавляем в буфер отправленную информацию
                          SetLength(s,Length(ABuffer));
                          Move(ABuffer[1],s[1],Length(ABuffer));
                          FResult.SendStr := FResult.SendStr + s;
                        end;
                         
                        procedure TGetHTTP.Free;
                        begin
                        //заменяем процедуру Free на нашу
                          Release;
                        end;
                         
                        //Получили новый запрос
                        procedure TGetHTTP.Get(const Query: String;const ProxyAddr: String='';
                          ProxyPort: integer=0);
                        var
                          p: PQProxy;
                        begin
                        //Заполняем структуру с параметрами
                          New(p);
                          p^.Proxy.ProxyAddr := ProxyAddr;
                          p^.Proxy.Port := ProxyPort;
                          p^.Query := Query;
                          PostThreadMessage(ThreadId,WM_ADD,Integer(p),0);
                        end;
                         
                        function TGetHTTP.GetConnectionTimeOut: Integer;
                        begin
                          Result := InterlockedExchange(FConnectionTimeOut,FConnectionTimeOut);
                        end;
                         
                         
                        procedure TGetHTTP.SetConnectionTimeOut(const Value: Integer);
                        begin
                          InterlockedExchange(FConnectionTimeOut,Value);
                        end;
                         
                        procedure TGetHTTP.SetReadTimeOut(const Value: Integer);
                        begin
                          InterlockedExchange(FReadTimeOut,Value);
                        end;
                         
                        procedure TGetHTTP.Release;
                        begin
                          FreeOnTerminate := True;      //Переводим в состояние автоуничтожения
                          Terminate;                    //Взводим флаг Terminated
                        end;
                         
                        //Закончить выполнение всех потоков
                        procedure TerminateAllThreads;
                        var
                          i: Integer;
                        begin
                          with ThrList.LockList do
                          try
                            for i := 0 to Count-1 do
                            begin
                              try
                                TGetHTTP(Items[i]).Release;
                              except
                              end;
                              //Sleep(100);///////////////////////////////////////////////////////////////!!!!!
                            end;
                          finally
                            ThrList.UnlockList;
                          end;
                        end;
                         
                        //Получить максимальное количество потоков.
                        function GetMaxThreads: Integer;
                        begin
                          Result := InterlockedExchange(MaxThreads,MaxThreads);
                        end;
                         
                        //Установить максимальное количество потоков.
                        procedure SetMaxThreads(aMaxThreads: Integer=10);
                        var
                          CurrValue: Integer;
                        begin
                          CurrValue := InterlockedExchange(MaxThreads,MaxThreads);
                          if CurrValue>aMaxThreads then
                          InterlockedExchange(MaxThreads,aMaxThreads);
                        end;
                         
                        //Получить теккущее количество потоков
                        function CheckCountThreads: Integer;
                        begin
                          with ThrList.LockList do
                          try
                            Result := Count;
                          finally
                            ThrList.UnlockList;
                          end;
                        end;
                         
                        //Завершить поток
                        procedure ReleaseThread(Thread:TGetHTTP);
                        var
                          i:Integer;
                        begin
                          with ThrList.LockList do
                          try
                            for i := 0 to Count-1 do
                            begin
                              try
                                if TGetHTTP(Items[i])=Thread then
                                begin
                                  TGetHTTP(Items[i]).Free;
                                  Delete(i);
                                  //Sleep(100);///////////////////////////////////////////////////////////!!!!!!!!!
                                  break;
                                end;
                              except
                              end;
                            end;
                          finally
                            ThrList.UnlockList;
                          end;
                        end;
                         
                        procedure TGetHTTP.Lock;
                        begin
                          EnterCriticalSection(FCS);
                        end;
                         
                        procedure TGetHTTP.Unlock;
                        begin
                          LeaveCriticalSection(FCS);
                        end;
                         
                        procedure TGetHTTP.FProgress;
                        var
                          r,s: Integer;
                        begin
                          if Assigned(FOnProgress) then
                          begin
                            Lock;
                            try
                              r := FResult.CountRcv;
                              s := FResult.CountSend;
                            finally
                              Unlock;
                            end;
                            FOnProgress(Self,r,s);
                          end;
                        end;
                         
                        function TGetHTTP.GetFResult: THTTPRec;
                        begin
                          Lock;
                          try
                            Result := FResult;
                          finally
                            Unlock;
                          end;
                        end;
                         
                         
                        function TGetHTTP.GetQueryCount: Integer;
                        begin
                          Result := FQuerylist.Count;
                        end;
                         
                        function TGetHTTP.GetReadTimeOut: Integer;
                        begin
                          Result := InterlockedExchange(FConnectionTimeOut,FConnectionTimeOut);
                        end;
                         
                        initialization
                          MaxThreads := 10;
                          ThrList := TThreadList.Create;
                        finalization
                          TerminateAllThreads;
                          ThrList.Free;
                        end.


                      ExpandedWrap disabled
                        unit Unit1;
                         
                        interface
                         
                        uses
                          Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
                          Dialogs, ExtCtrls, ComCtrls, StdCtrls,
                          FineProxy,  uGetHttpThread, Shared,
                          ClipBrd, jpeg, PngImage, Buttons, ImgList, XPMan;
                         
                        type
                          TForm1 = class(TForm)
                            Panel1: TPanel;
                            SaveDialog1: TSaveDialog;
                            Image1: TImage;
                            Label1: TLabel;
                            ImageList1: TImageList;
                            StatusBar1: TStatusBar;
                            BitBtn2: TBitBtn;
                            BitBtn1: TBitBtn;
                            BitBtn3: TBitBtn;
                            BitBtn4: TBitBtn;
                            XPManifest1: TXPManifest;
                            OpenDialog1: TOpenDialog;
                            GroupBox7: TGroupBox;
                            Label2: TLabel;
                            LabeledEdit1: TLabeledEdit;
                            UpDown1: TUpDown;
                            Label3: TLabel;
                            Label4: TLabel;
                            CheckBox7: TCheckBox;
                            ListView1: TListView;
                            ProgressBar1: TProgressBar;
                            UpDown2: TUpDown;
                            LabeledEdit2: TLabeledEdit;
                            procedure ListView1Click(Sender: TObject);
                            procedure FormResize(Sender: TObject);
                            procedure FormCreate(Sender: TObject);
                            procedure BitBtn1Click(Sender: TObject);
                            procedure BitBtn2Click(Sender: TObject);
                            procedure BitBtn3Click(Sender: TObject);
                            procedure StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
                              const Rect: TRect);
                            procedure BitBtn4Click(Sender: TObject);
                          private
                            { Private declarations }
                          public
                            { Public declarations }
                            function GetSite(const URL: string): String;
                            procedure Complete(Sender: TGetHTTP; var Action:TActionHTTPThread);
                            function AddThr: Boolean;
                            function IsDoneChecking(L: TListView): Boolean;
                            function FindItem(L: TListView; Server, Port: String): Integer;
                            Procedure Log(Value: String);
                            procedure PreWork(StartMsg: String; DisabledButton: TBitBtn);
                            procedure PostWork(EndMsg: String);
                            function CheckedCount(L: TListView): Integer;
                            function ValidCount(L: TListView): Integer;
                            function ErrorCount(L: TListView): Integer;
                            function Total(L: TListView): Integer;
                            procedure CopyToClpbrd(L: TListView);
                            procedure SetCanceled(L: TListView);
                          end;
                         
                        var
                          Form1: TForm1;
                          C: TClipBoard;
                          //
                          FP: TFineProxy;
                          //
                          WorkRunning: Boolean;
                          STOP: Boolean;
                          //
                          CurIP: String;
                          CurAdded: Integer;
                          //CurListView: Cardinal;//1=ListView1 etc
                         
                        implementation
                         
                        {$R *.dfm}
                         
                        ....................................................
                         
                        ////////////////////////////////////////////////////////////////////////////////
                         
                        Procedure SetTimeOut(Value: Cardinal);
                        var
                          TicksNow: Cardinal;
                        begin
                          TicksNow := GetTickCount;
                          repeat
                            Sleep(100);
                            if STOP then
                            BREAK;//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                            Application.ProcessMessages;
                          until GetTickCount - TicksNow >= Value;
                        end;
                         
                        Procedure TForm1.Log(Value: String);
                        begin
                          //Form1.Memo1.Lines.Add('['+TimeToStr(Now)+'] '+Value);
                          StatusBar1.Panels[1].Text := Value;
                        end;
                         
                        function TForm1.AddThr: Boolean;
                        begin
                          Result := False;
                          try
                            with TGetHTTP.Create do
                            begin
                              OnComplete := Complete;
                              {ConnectionTimeout := 5000;
                              ReadTimeout := 5000;}
                              //Deafult 10000
                            end;
                            Result := True;
                          except
                          end;
                        end;
                         
                        ........................................................
                         
                        function TForm1.FindItem(L: TListView; Server, Port: String): Integer;
                        var
                        I: Integer;
                        S1, S2: String;
                        begin
                        RESULT := -1;
                        for I := 0 to L.Items.Count - 1 do
                        begin
                        S1 := L.Items[I].Caption;
                        S2 := L.Items[I].SubItems[0];
                        if (S1 = Server) and (S2 = Port) then
                        RESULT := I;
                        if RESULT > -1 then
                        BREAK;
                        Application.ProcessMessages;
                        end;
                        end;
                         
                        procedure TForm1.Complete(Sender: TGetHTTP; var Action: TActionHTTPThread);
                        var
                          thr: TGetHTTP;
                          I: Integer;
                        begin
                          Thr := Sender;
                          //
                          if Thr.State = shComplete then
                          begin
                            if CurAdded > 0 then
                            CurAdded := CurAdded - 1 else
                            CurAdded := 0;
                          end;
                          //memo1.Lines.Add('Done');
                          //
                          I := FindItem(ListView1, Thr.Result.ProxyServer, IntToStr(Thr.Result.ProxyPort));
                          if I > -1 then
                          begin
                          //
                          if thr.Result.ErrorCode = 200 then
                          ListView1.Items[I].SubItems[1] := 'OK' else
                          begin
                          if POSNew('timed out', Thr.Result.ErrorMsg) <> 0 then
                          ListView1.Items[I].SubItems[1] := 'ERROR: Прокси-сервер слишком медленный (' + Thr.Result.ErrorMsg + ')' else
                          if POSNew('Too many', Thr.Result.ErrorMsg) <> 0 then
                          ListView1.Items[I].SubItems[1] := 'ERROR: Прокси-сервер слишком слабый (' + Thr.Result.ErrorMsg + ')' else
                          ListView1.Items[I].SubItems[1] := 'ERROR: Прокси-сервер не валидный (' + Thr.Result.ErrorMsg + ')';
                          end;
                          if ParseIP(Thr.Result.RecvStr) = CurIP then
                          ListView1.Items[I].SubItems[1] := 'ERROR: Прокси-сервер не анонимный';
                          //
                          ProgressBar1.Position := CheckedCount(ListView1) * 100 div Total(ListView1);
                          //
                          if STOP then
                          LOG('Прерывание... [Всего: ' + IntToStr(Total(ListView1)) + ' Валидных/Невалидных: ' + IntToStr(ValidCount(ListView1)) + '/' + IntToStr(ErrorCount(ListView1)) + ']') else
                          LOG('Проверка списка прокси [Всего: ' + IntToStr(Total(ListView1)) + ' Валидных/Невалидных: ' + IntToStr(ValidCount(ListView1)) + '/' + IntToStr(ErrorCount(ListView1)) + ']');
                          //
                          {if Thr.QueryCount = 0 then
                          Action := ahFree;}
                          //
                          //if {IsDoneChecking(ListView1)}(CheckCountThreads < GetMaxThreads) or STOP then
                          //begin
                          //if Thr.QueryCount = 0 then
                          //Action := ahFree;
                          //end;
                          end;
                        end;
                         
                        ////////////////////////////////////////////////////////////////////////////////
                         
                        .............................................................
                         
                        .....................................................
                         
                        ..........................................................
                         
                        procedure TForm1.BitBtn2Click(Sender: TObject);
                        var
                          i, j: integer;
                        begin
                        //WorkRunning := (CheckCountThreads > 0);
                        if WorkRunning then
                        begin
                          STOP := TRUE;
                          TerminateAllThreads;
                          BitBtn2.Enabled := FALSE;
                          {Log('Прерывание...');
                          SetTimeOut(1000);}
                          while CheckCountThreads > 0 do
                          SetTimeOut(500);
                          Log('Проверка прокси прервана пользователем');
                          SetTimeOut(1000);
                          PostWork('Готово [Всего: ' + IntToStr(Total(ListView1)) + ' Валидных/Невалидных: ' + IntToStr(ValidCount(ListView1)) + '/' + IntToStr(ErrorCount(ListView1)) + ']');//Статистика по проверенным прокси
                          //BitBtn2.Enabled := TRUE;
                          SetCanceled(ListView1);
                          //TerminateAllThreads;
                        end else
                        begin
                        //
                        if ListView1.Items.Count > 0 then
                        begin
                          CurIP := GetIPAdress;
                          //ShowMessage('Ваш IP: ' + CurIP);
                        //CurListView := 0;
                        SetMaxThreads(UpDown2.Position);
                        BitBtn2.Caption := 'Остановить';
                          BitBtn2.Glyph := nil;
                          ImageList1.GetBitmap(2, BitBtn2.Glyph);
                          Application.ProcessMessages;
                          PreWork('Проверка списка прокси...', BitBtn1);
                          //SetTimeOut(1000);
                        //
                          {CurListView := GetListViewIndex(L);
                          WriteStartLogFromListViewName(L);}
                          //LOG('Проверка списка прокси...');
                          //
                          CurAdded := 0;
                          //
                          while AddThr do;
                          {j := 0;
                          with ThrList.LockList do
                          try
                            for i  := 0 to ListView1.Items.Count - 1 do
                            begin
                              //
                              while CurAdded = 10 do
                              SetTimeOut(500);
                              //
                              if j>Count-1 then
                              j := 0;
                              ListView1.Items[i].SubItems[1] := 'Checking...';
                                TGetHTTP(Items[j]).Get(
                                  'http://internet.yandex.ru/',
                                  ListView1.Items[i].Caption,//Server
                                  StrToInt(ListView1.Items[i].SubItems[0]));//Port
                              inc(j);
                              //
                              if STOP then
                              BREAK;
                              //
                              Inc(CurAdded);
                              //
                            end;
                          finally
                            ThrList.UnlockList;
                          end;
                          end;}
                          j := 0;
                          //
                          with ThrList.LockList do
                          try
                          //
                          for i  := 0 to ListView1.Items.Count - 1 do
                          begin
                          //
                          while CurAdded = 10 do
                          SetTimeOut(500);
                          //
                              if j>Count-1 then
                              j := 0;
                              ListView1.Items[i].SubItems[1] := 'Checking...';
                                TGetHTTP(Items[j]).Get(
                                  'http://internet.yandex.ru/',
                                  ListView1.Items[i].Caption,//Server
                                  StrToInt(ListView1.Items[i].SubItems[0]));//Port
                              inc(j);
                              //
                              if STOP then
                              BREAK;
                              //
                              Inc(CurAdded);
                              //
                          end;
                              //
                          finally
                            ThrList.UnlockList;
                          end;
                          //
                        end;
                        end;
                        end;
                         
                        ...............................................
                         
                        end.


                      ЗЫ
                      Сорри за форматирование, нет под рукой полной версии D2010
                        Я когда то делал массив потоков. Через конструктор собирал, и передавал в поток необходимые парамеиры. Только результаты у меня в базу писались.
                        Array of Thread. Делал динамическим. Перед началом задавал величину массива (количество потоков)
                        1 пользователей читают эту тему (1 гостей и 0 скрытых пользователей)
                        0 пользователей:


                        Рейтинг@Mail.ru
                        [ Script Execution time: 0,1663 ]   [ 15 queries used ]   [ Generated: 28.02.20, 01:50 GMT ]