main.pas

ThreadPro 是本人开发的一套用于多线程编程的 Delphi 基础类库

procedure TfrmDemo.btnStartClick(Sender: TObject);

  procedure LoadCheckProxyTask(TaskList : TThreadList);
  var
    Param : PCheckProxyParam;
    i: Integer;
  begin
    for i:=lvPxy.Items.Count-1 downto 0 do     //装载任务列表时请使用倒顺序
    begin
      GetMem(Param,SizeOf(TCheckProxyParam));
      Param^.IP := #0;
      StrPCopy(Param^.IP, Trim(lvPxy.Items[i].SubItems[0]));
      Param^.Port := StrToInt(Trim(lvPxy.Items[i].SubItems[1]));
      LoadTask(i,Param,TaskList);
    end;
  end;

begin
  if lvPxy.Items.Count=0 then Exit;
  if (Trim(edtPxyChkUrl.Text)='') or (Trim(edtPxySuccStr.Text)='') then exit;
  PreStart;
  with CheckProxyPool do
  begin
    LoadCheckProxyTask(_TASK_LIST);
    SetChkPxyTaskBtnStat(bsRunning);
    Start;
  end;
end;

procedure TfrmDemo.PreStart;
begin
  if CheckProxyPool <> nil then Exit;
  LockLvPxy(False);
  CheckProxyPool := TCheckProxyPool.Create;
  with CheckProxyPool do
  begin
    _THREAD_CLASS := TCheckProxy ;        //任务对象类型
    _THREAD_COUNT := tkbPxy.Position;     //并发线程数
    _OnTerminate := CheckProxyPoolDone;   //任务结束事件
    _OnForceStop := CheckProxyPoolStop;     //手动终止事件
    _OnTraceLog := CheckProxyPoolTrace;     //线程池状态跟踪事件
    P_OnLvTraceLog := LvPxyTraceLog;        //线程状态跟踪事件
    P_READ_TIME_OUT := udChkPxyTimeOut.Position*1000;  //HTTP请求超时
    P_TARGET_URL := edtPxyChkUrl.Text;                 //目标网址
    P_SUCC_STR := edtPxySuccStr.Text;                  //成功字串
    _PROGRESS_BAR := pbChkPxy;                         //总进度条
    _TERM_PRO_BAR := pbTerm;                           //线程池进度条
  end;
end;


procedure TfrmDemo.FormCreate(Sender: TObject);
begin
  Application.Title := APP_TITLE ;
  AppPath := ExtractFilePath(ParamStr(0));
  ConfigIni := TIniFile.Create(AppPath + CFG_FILE);
  //
  SetChkPxyTaskBtnStat(bsNull);
  SetTaskBtnStat(bsNull);
  //initialize WebSearchHolder
  WebSearchHolder := TWebSearchHolder.Create;
  with WebSearchHolder do
  begin
    _AC_START := actBeginSearch;
    _AC_PAUSE := actPauseSearch;
    _AC_GOON  := actGoonSearch ;
    _AC_STOP  := actStopSearch ;
    _EngineChkLst := chklstWebEngine;
    _OnTerminate := WebSearchDone;
    H_OnSrhRetFind := WebSearchFind;
    SetActStatus(bsxNull);
  end;
  LoadWebEngine;
end;

procedure TfrmDemo.tkbPxyChange(Sender: TObject);
begin
  lblThreadCount.Caption := IntToStr(tkbPxy.Position);
end;

procedure TfrmDemo.actLvPxyImportExecute(Sender: TObject);
var
  Dialog : TOpenDialog;
begin
  try
  Dialog := TOpenDialog.Create(Self);
  try
    with Dialog do
    begin
      Filter := '文本文件(*.txt)|*.txt';
      DefaultExt := '.txt';
      if Execute then
      try
        LoadLvPxy(FileName);
      except
        ShowMessage('ImErr!');
      end;
    end;
  finally
    Dialog.Free;
  end;
  except
    ShowMessage('ImDlgErr');
  end;
end;

procedure TfrmDemo.actLvPxyExportExecute(Sender: TObject);
var
  Dialog : TSaveDialog;
begin
  Dialog := TSaveDialog.Create(Self);
  try
    with Dialog do
    begin
      Filter := '文本文件(*.txt)|*.txt';
      DefaultExt := '.txt';
      if Execute then
        SaveLvPxy(FileName);
    end;
  finally
    Dialog.Free;
  end;
end;

procedure TfrmDemo.actLvPxyDelSelExecute(Sender: TObject);
begin
  lvPxy.DeleteSelected;
end;

procedure TfrmDemo.actLvPxyDelFailExecute(Sender: TObject);
var
  i : Integer;
begin
  with lvPxy do
  begin
    for i:=items.Count-1 downto 0 do
      if items[i].ImageIndex = 2 then
        items[i].Selected := true
        else
        items[i].Selected := False;
    DeleteSelected;
  end;
end;

procedure TfrmDemo.actLvPxyClearExecute(Sender: TObject);
begin
  LvPxy.Clear;
end;

procedure TfrmDemo.btnGoonClick(Sender: TObject);

  function LoadCheckProxyTask(TaskList : TThreadList) : Integer;
  var
    Param : PCheckProxyParam;
    i: Integer;
  begin
    Result := 0;
    for i:=lvPxy.Items.Count-1 downto 0 do     //装载任务列表时请使用倒顺序
    begin
      if (lvPxy.Items[i].ImageIndex in [1,2]) then Continue;
      Inc(Result);
      GetMem(Param,SizeOf(TCheckProxyParam));
      Param^.IP := #0;
      StrPCopy(Param^.IP, Trim(lvPxy.Items[i].SubItems[0]));
      Param^.Port := StrToInt(Trim(lvPxy.Items[i].SubItems[1]));
      LoadTask(i,Param,TaskList);
    end;
  end;

begin
  if (Trim(edtPxyChkUrl.Text)='') or (Trim(edtPxySuccStr.Text)='') then exit;
  PreStart;
  with CheckProxyPool do
  begin
    if LoadCheckProxyTask(_TASK_LIST) = 0 then
    begin
      FreeAndNil(CheckProxyPool);
      Exit;
    end;
    SetChkPxyTaskBtnStat(bsRunning);
    Start;
  end;
end;

procedure TfrmDemo.btnStopClick(Sender: TObject);
begin
  if CheckProxyPool = nil then Exit;
  CheckProxyPool.Stop;
end;

procedure TfrmDemo.lvPxyColumnClick(Sender: TObject; Column: TListColumn);
begin
  if lvPxy.Tag = 1 then Exit;
  ColToSort := Column.Index;
  (Sender as TCustomListView).AlphaSort;
  RfhLstV(LvPxy);
  bUp := not bUp;
end;

procedure TfrmDemo.lvPxyCompare(Sender: TObject; Item1, Item2: TListItem;
  Data: Integer; var Compare: Integer);
var
  ix: Integer;
begin
  if ColToSort = 0 then
    if bUp then
    Compare := CompareText(Item1.Caption,Item2.Caption)
    else
    Compare := CompareText(Item2.Caption,Item1.Caption)
  else begin
   ix := ColToSort - 1;
   if bUp then
   Compare := CompareText(Item1.SubItems[ix],Item2.SubItems[ix])
   else
   Compare := CompareText(Item2.SubItems[ix],Item1.SubItems[ix]);
  end;
end;

procedure TfrmDemo.actLvPxyResetExecute(Sender: TObject);
var
  i : Integer;
begin
  with LvPxy do
  begin
    for i:=0 to Items.Count-1 do
    begin
      Items[i].ImageIndex := 0;
      Items[i].Checked := False;
      Items[i].SubItems[2] := '';
      Items[i].SubItems[3] := '';
    end;
  end;
end;

procedure TfrmDemo.tkbTraceChange(Sender: TObject);
begin
  lblTrace.Caption := IntToStr(tkbTrace.Position);
end;

procedure TfrmDemo.btnRndParamClick(Sender: TObject);
var
  i : Integer;
  Item : TListItem;
begin
  with lvTask do
  begin
    Clear;
    for i:=1 to udTaskCount.Position do
    begin
      Item := Items.Add;
      Item.Caption := IntToStr(i);
      Item.SubItems.Add(Format('延时 %d 毫秒',[Random(3000)+2000]));
      Item.SubItems.Add('');
      Item.SubItems.Add('');
    end;
  end;
end;

procedure TfrmDemo.btnTaskStartClick(Sender: TObject);
  procedure LoadDemoTask(TaskList : TThreadList);
  var
    Param : PDemoParam;
    i: Integer;
    Relay : string;
  begin
    for i:=lvTask.Items.Count-1 downto 0 do     //装载任务列表时请使用倒序
    begin
      GetMem(Param,SizeOf(TDemoParam));
      Relay := GetDigAt(Trim(lvTask.Items[i].SubItems[0]),'毫秒',True);
      Param^.Relay := StrToInt(Relay);
      LoadTask(i,Param,TaskList);
    end;
  end;
  procedure CreateLvTraceView;
  var
    TaskCount,i : Integer;
    Item : TListItem;
  begin
    lvTrace.Clear;
    TaskCount := tkbTrace.Position;
    if TaskCount>lvTask.Items.Count then
    TaskCount := lvTask.Items.Count;
    for i:=0 to TaskCount-1 do
    begin
      Item := lvTrace.Items.Add;
      Item.Caption := FormatStrNum(i,3);
      Item.SubItems.Add('');
      Item.SubItems.Add('');
    end;
  end;
begin
  if lvTask.Items.Count=0 then Exit;
  if DemoPool <> nil then Exit;
  DemoPool := TThreadPoolDemo.Create;
  with DemoPool do
  begin
    _RUN_ORDER := TRunOrder(rgRunOrder.ItemIndex);
    _RUN_MODE := TRunMode(rgRunMode.ItemIndex);
    _PROGRESS_BAR := pbTotal;
    _TERM_PRO_BAR := pbTaskTerm;
    _THREAD_CLASS := TThreadTaskDemo ;        //任务对象类型
    _THREAD_COUNT := tkbTrace.Position;     //并发线程数
    _OnTerminate := DemoPoolDone;
    _OnForceStop := DemoPoolStop;
    P_OnLvTraceLog := DemoPoolLvTrace;
    P_OnTraceLog := DemoPoolTrace;
    LoadDemoTask(_TASK_LIST);
    CreateLvTraceView;
    SetTaskBtnStat(bsRunning);
    Start;
  end;
end;

procedure TfrmDemo.btnTaskStopClick(Sender: TObject);
begin
  if DemoPool = nil then Exit;
  DemoPool.Stop;
end;

procedure TfrmDemo.btn10Click(Sender: TObject);
begin
  lstLog.Clear;
end;

procedure TfrmDemo.btn9Click(Sender: TObject);
begin
  lvTrace.Clear;
end;

procedure TfrmDemo.actBeginSearchExecute(Sender: TObject);
begin
  if Trim(edtKeyWord.Text) = '' then
  begin
    MsgBox('关键词不能为空！',0);
    Exit;
  end;
  with WebSearchHolder do
  begin
    H_KEYWORD := Trim(edtKeyWord.Text);
    H_PAGENUM := udPageNo.Position;
    Start;
  end;
end;

procedure TfrmDemo.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SaveWebEngine;
  ConfigIni.Free;
  WebSearchHolder.Free;
end;

procedure TfrmDemo.actPauseSearchExecute(Sender: TObject);
begin
  WebSearchHolder.Pause;
end;

procedure TfrmDemo.actGoonSearchExecute(Sender: TObject);
begin
  WebSearchHolder.Goon;
end;

procedure TfrmDemo.actStopSearchExecute(Sender: TObject);
begin
  WebSearchHolder.Stop;
  MsgBox('搜索任务被强行终止！',0);
end;

procedure TfrmDemo.lvSearchDblClick(Sender: TObject);
begin
  OpenUrlLv(lvSearch,1);
end;

procedure TfrmDemo.btn27Click(Sender: TObject);
begin
  CheckChkLst(chklstWebEngine,True);
end;

procedure TfrmDemo.btn28Click(Sender: TObject);
begin
  CheckChkLst(chklstWebEngine,False);
end;

procedure TfrmDemo.btn11Click(Sender: TObject);
begin
  lvSearch.Clear;  
end;

procedure TfrmDemo.btn13Click(Sender: TObject);
begin
  lvSearch.DeleteSelected;
  RfhLstV(lvSearch);
end;

procedure TfrmDemo.N7Click(Sender: TObject);
begin
  OpenUrl('http://www.flying99koo.com');
end;

end.