Question

所以我的代码执行此操作：

以线程下载页面
解析页面
将其发送至主线程

所有这些都是在关键部分和postmessage上完成的。如果任何人都可以检查它修复它改变它，或任何其他可以使它更好。

Main VCL form :

    unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OverbyteIcsWndControl, OverbyteIcsHttpProt, StdCtrls,Unit2;
const
  WM_DATA_IN_BUF = WM_APP + 1000;

type
  TForm1 = class(TForm)
    HttpCli1: THttpCli;
    Button1: TButton;
    ListBox1: TListBox;
    Memo1: TMemo;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FStringSectInit: boolean;
    FGoogle: TGoogle;
    FStringBuf: TStringList;
    procedure HandleNewData(var Message: TMessage); message WM_DATA_IN_BUF;
  public
     StringSection: TRTLCriticalSection;
    property StringBuf: TStringList read FStringBuf write FStringBuf;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not FStringSectInit then
  begin
    InitializeCriticalSection(StringSection);
    FStringBuf := TStringList.Create;
    FStringSectInit := true;
    FGoogle := TGoogle.Create(true);
    SetThreadPriority(FGoogle.Handle, THREAD_PRIORITY_BELOW_NORMAL);
    try
      FGoogle.StartNum := 8;
    except
      on EConvertError do FGoogle.StartNum := 2;
    end;
    FGoogle.Resume;
  end;
end;

procedure TForm1.HandleNewData(var Message: TMessage);
var i:integer;
begin
  if FStringSectInit then
  if listbox1.Items.Count<10 then
  begin
    EnterCriticalSection(StringSection);
    for i:=0 to 5 do
    if length(fstringbuf.Text)>10 then
    begin
    listbox1.Items.Add(FStringBuf.Strings[i]);
    end
    else
    FStringBuf.Clear;
    LeaveCriticalSection(StringSection);
    {Now trim the Result Memo.}
  end
  else
  begin
    with FGoogle do
    begin
      Terminate;
      WaitFor;
      Free;
    end;
   FGoogle := nil;
    FStringBuf.Free;
    FStringBuf := nil;
    DeleteCriticalSection(StringSection);
    FStringSectInit := false;
  end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if listbox1.Items.Count>80 then
end;

end.

线程：

unit Unit2;

interface

uses
  Classes,Windows,IDHTTP, OverbyteIcsWndControl, StdCtrls,OverbyteIcsHttpProt,SysUtils,Dialogs;

type
  TGoogle = class(TThread)
  private
google:TStringList;
    Upit:string;
    Broj:integer;
    Buffer : TStringList;
  protected
    procedure parsegoogleapi;
    procedure SkiniSors;
    procedure Execute; override;
  public
    property StartNum: integer read Broj write Broj;
  end;

implementation
uses unit1,StrUtils;

function ExtractText(const Str, Delim1, Delim2: string; PosStart: integer; var PosEnd: integer): string;
var
 pos1, pos2: integer;
begin
    Result := '';
    pos1 := PosEx(Delim1, Str, PosStart);
    if pos1 > 0 then
    begin
    pos2 := PosEx(Delim2, Str, pos1 + Length(Delim1));
    if pos2 > 0 then
    begin
      PosEnd := pos2 + Length(Delim2);
      Result := Copy(Str, pos1 + Length(Delim1), pos2 - (pos1 + Length(Delim1)));
end;
end;
end;
function ChangeString(const Value: string; replace:string): string;
var i: Integer;
begin
    Result := '';
    for i := 1 to Length(Value) do
    if Value[i] = ' ' then
    Result := Result + replace
    else
    Result := Result + Value[i]
end;

(*Ovo je procedura za skidanje sorsa*)

procedure TGoogle.SkiniSors;
var
HttpCli1 : THttpCli;
criter:string;

begin

HttpCli1:=THttpCli.Create(nil);
google:=TStringList.Create;
criter:= ChangeString(Upit,'%20');

With HttpCli1 do begin
    URL            := 'http://ajax.googleapis.com/ajax/services/search/web?v=1.0&start=' + inttostr(broj) + '&rsz=large&q=index.php';
    RequestVer     := '1.1';
    RcvdStream := TMemoryStream.Create;
    try
        Get;
    except
        ShowMessage('There has been an error , check your internet connection !');
        RcvdStream.Free;
        Exit;
    end;

RcvdStream.Seek(0,0);
google.LoadFromStream(RcvdStream);
RcvdStream.Free;
 broj:=broj+8;
ParseGoogleApi;
end;
end;

procedure TGoogle.ParseGoogleApi;
var Pos: integer;
    sText: string;
begin
Buffer:= TStringList.Create;
  sText := ExtractText(google.Text, '"url":"', '","visibleUrl"', 1, Pos);
  while sText <> '' do
  begin
    buffer.Add(sText);

    sText := ExtractText(google.Text, '"url":"', '","visibleUrl"', Pos, Pos);
  end;
end;


procedure TGoogle.Execute;
var
  CurrentNum: integer;
  i:integer;

begin

  CurrentNum := Broj;
  while not terminated do
  begin
  skinisors;
      EnterCriticalSection(Form1.StringSection);
      for i:=0 to 5 do                        begin
      Form1.StringBuf.Add(buffer.strings[i]);
      end;
      LeaveCriticalSection(Form1.StringSection);
      PostMessage(Form1.Handle, WM_DATA_IN_BUF, 0, 0);

    end;


end;
end.

所以我想知道如何在页面超时或用户断开连接等时停止线程，以便线程可以正常终止。

我想启动此线程的3个实例，并且每个实例都应该访问临界区，取一个链接ex link [i]其中i是整数值，该值由当时具有关键部分所有权的线程递增。谢谢

Answer 1

为您的线程提供一个构造函数，并在该构造函数中设置FreeOnTerminate := True;。

在线程的execute方法中，您可以在页面超时或断开连接时调用Terminate;。

Delphi线程[查看我的代码]

1 个答案: