А зачем для использования Indy нужны формы?
Вот пример выполнения в потоке, делал для сорцов. Здесь Forms не используется.
| Код |
{
Модуль uGetHTTPThread
Выполнение запроса HTTP GET в отдельном потоке с
возможностью повторного использования.
Ведется учет количества потоков
Требования - установленный Indy10
(c) Демо
Специально для Sources.ru (2005)
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
s: String;
begin
with TGetHTTP.Create do
begin
OnComplete := Complete;
Get('http://www.sources.ru');
end;
with TGetHTTP.Create do
begin
OnComplete := Complete;
Get('http://localhost');
end;
procedure TForm1.Complete(Sender: TGetHTTP; var Action: TActionHTTPThread);
begin
Memo1.Lines.Add('Complete');
Memo1.Lines.Add(Sender.Result.RecvStr);
Action := ahFree;
end;
}
unit uGetHttpThread;
interface
uses
windows,classes, SysUtils, idHTTP, idLogDebug, idComponent, idGlobal,IdIOHandler,
IdIOHandlerSocket, IdIOHandlerStack, IdIntercept,idException;
var
ThrList: TThreadList;
type
//Состояние потока
TStateHTTPThread=(shNone,shReady,shComplete,shWork);
//Действие при обработке OnComplete
TActionHTTPThread=(ahNone,ahFree);
TGetHTTP=class;
TCompleteQuery=procedure(Sender: TGetHTTP; var Action:TActionHTTPThread) of Object;
//Структура, заполняемая в потоке.
THTTPRec=record
Query: String; //Запрос в виде http://url
ErrorMsg: String; //Результатт в текстовом виде
ErrorCode: Integer; //Результат в числовом виде
RecvStr: String; //Принятая строка(полностью с заголовком)
SendStr: String; //Отосланная строка
CountSend: Integer; //Количество отосланных байт
CountRcv: Integer; //Количество принятых байт
Page: String; //Возвращенная страница(без заголовка)
end;
//Собственно, сам поток
TGetHTTP=class(TThread)
private
FH: TidHTTP;
FL: TidLogDebug;
FS: TIdIOHandlerStack;
FTimeOut: Integer;
FQuery: String;
FResult: THTTPRec;
FState: TStateHTTPThread;
FOnComplete: TCompleteQuery;
procedure FComplete;
procedure FHWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
procedure FLReceive(ASender: TIdConnectionIntercept;
var ABuffer: TBytes);
procedure FLSend(ASender: TIdConnectionIntercept;
var ABuffer: TBytes);
function GetTimeOut: Integer;
procedure SetTimeOut(const Value: Integer);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Free;
procedure Release;
procedure Get(const Query: String);
property OnComplete: TCompleteQuery read FOnComplete write FOnComplete;
property Result: THTTPRec read FREsult;
property State: TStateHTTPThread read FState;
property TimeOut: Integer read GetTimeOut write SetTimeOut;
end;
//Получение максимального количества потоков
function GetMaxThreads: Integer;
//Установка максимального количества потоков
procedure SetMaxThreads(aMaxThreads: Integer=10);
//завершение всех потоков и очистка списка
procedure TerminateAllThreads;
//Завершение конкретного потока
procedure ReleaseThread(Thread:TGetHTTP);
//Получение количества потоков в списке
function CheckCountThreads: Integer;
implementation
var
//Максимальное количество потоков - недоступно из других модулей напрямую
MaxThreads: Integer;
{ TGetHTTP }
constructor TGetHTTP.Create;
begin
if CheckCountThreads=GetMaxThreads then raise Exception.Create('Can''t create thread. MaxThreads='+IntToStr(MaxThreads));
inherited Create(True);
FreeOnTerminate := False;
FState := shNone; //Поток еще не готов принять запрос
with ThrList.LockList do //Добавляем поток в список
try
Add(Self);
finally
ThrList.UnlockList;
end;
TimeOut := 30000;
Resume;
end;
destructor TGetHTTP.Destroy;
begin
FH.Free;
FS.Free;
FL.Free;
end;
procedure TGetHTTP.Execute;
begin
FH := TidHTTP.Create(nil);
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;
FState := shReady;
if FQuery='' then Suspend; //Запрос пустой - засыпаем
try
while not Terminated do
begin
FState := shWork; //Поток занят
FResult.Query := FQuery;
FResult.ErrorMsg := '';
FResult.ErrorCode := 0;
FResult.RecvStr := '';
FResult.SendStr := '';
FResult.CountSend := 0;
FResult.CountRcv := 0;
FResult.Page := '';
FQuery := '';
try
FH.ReadTimeout := TimeOut; //Таймаут
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;
FState := shComplete; //Поток закончил выполнение запроса
Synchronize(FComplete); //Сообщаем пользователю
if not Terminated then Suspend;
end;
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 Terminate;//ReleaseThread(Self) //Завершаем поток
// else Suspend; //Засыпаем снова - до следующего запроса
end;
procedure TGetHTTP.FHWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
begin
//Увеличиваем соответствующий счетчик
case AWorkMode of
wmRead: FResult.CountRcv := FResult.CountRcv + AWorkCount;
wmWrite: FResult.CountSend := FResult.CountSend + AWorkCount;
end;
end;
procedure TGetHTTP.FLReceive(ASender: TIdConnectionIntercept;
var ABuffer: TBytes);
var
s: String;
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;
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);
var
i: Integer;
begin
//Проверяем, закончена ли предыдущая обработка.
if (FState=shComplete) or (FState=shWork)
then raise Exception.Create('Error state thread');
//Если поток еще толтько стартует - ожидаем.
i := 100;
while FState<>shReady do
begin
Sleep(10);
//Слишком долго поток не переходит в статус shReady
if i<0 then raise Exception.Create('Unknown error');
Dec(i,10);
end;
FQuery := Query;
//Будим поток для выполнения запроса
Resume;
end;
function TGetHTTP.GetTimeOut: Integer;
begin
Result := InterlockedExchange(FTimeOut,FTimeOut);
end;
procedure TGetHTTP.SetTimeOut(const Value: Integer);
begin
InterlockedExchange(FTimeOut,Value);
end;
procedure TGetHTTP.Release;
begin
FreeOnTerminate := True; //Переводим в состояние автоуничтожения
Terminate; //Взводим флаг Terminated
Resume; //Будим поток для завершения
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;
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);
break;
end;
except
end;
end;
finally
ThrList.UnlockList;
end;
end;
initialization
MaxThreads := 10;
ThrList := TThreadList.Create;
finalization
TerminateAllThreads;
ThrList.Free;
end.
|
Или вот:
| Код |
program SetTime;
uses
Windows, SysUtils, IdTime;
var
CurrTime: TDateTime;
st: TSystemTime;
YY,MM,DD,HH,NN,SS,MS: Word;
begin
try
with tIdTime.Create(nil) do
begin
// Host := 'ntps1-0.uni-erlangen.de';
Host := '192.168.0.1';
try
CurrTime := DateTime;
except
end;
Free;
end;
except
Exit;
end;
GetLocalTime(st);
DecodeDate(CurrTime,YY,MM,DD);
DecodeTime(CurrTime,HH,NN,SS,MS);
st.wYear := YY;
st.wMonth := MM;
st.wDay := DD;
st.wHour := HH;
st.wMinute := NN;
st.wSecond := SS;
st.wMilliseconds := MS;
SetLocalTime(st);
end.
|
|
Прикольно 
