📄 main.pas

📁 ThreadPro 是本人开发的一套用于多线程编程的 Delphi 基础类库
💻 PAS
📖 第 1 页 / 共 2 页
字号:
12 下一页
unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  MyThreadPool,
  MyHTTPTask,
  ThreadPool,
  Define,
  Dialogs, ComCtrls, StdCtrls, ExtCtrls, ActnList, ToolWin, ImgList, Menus,
  CheckLst,
  IniFiles,
  WebSearchHolder;

type
  TfrmDemo = class(TForm)
    actlst: TActionList;
    actLvPxyImport: TAction;
    actLvPxyExport: TAction;
    actLvPxyDelSel: TAction;
    actLvPxyDelFail: TAction;
    actLvPxyClear: TAction;
    pm: TPopupMenu;
    il: TImageList;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    actLvPxyReset: TAction;
    pgcMain: TPageControl;
    ts: TTabSheet;
    ts1: TTabSheet;
    ts2: TTabSheet;
    pnl2: TPanel;
    lbl4: TLabel;
    lbl5: TLabel;
    pbChkPxy: TProgressBar;
    pbTerm: TProgressBar;
    stat: TStatusBar;
    lvPxy: TListView;
    tlb: TToolBar;
    btn1: TToolButton;
    btn2: TToolButton;
    btn5: TToolButton;
    btn3: TToolButton;
    btn4: TToolButton;
    btn6: TToolButton;
    pnl1: TPanel;
    lbl1: TLabel;
    lbl2: TLabel;
    lbl3: TLabel;
    lblThreadCount: TLabel;
    btnStart: TButton;
    btnGoon: TButton;
    btnStop: TButton;
    tkbPxy: TTrackBar;
    edtChkPxyTimeOut: TEdit;
    udChkPxyTimeOut: TUpDown;
    edtPxyChkUrl: TEdit;
    edtPxySuccStr: TEdit;
    pnl3: TPanel;
    pnl4: TPanel;
    grp1: TGroupBox;
    spl1: TSplitter;
    grp2: TGroupBox;
    lstLog: TListBox;
    lvTask: TListView;
    tkbTrace: TTrackBar;
    spl2: TSplitter;
    grp3: TGroupBox;
    lvTrace: TListView;
    tlb1: TToolBar;
    tlb2: TToolBar;
    btnTraceLog: TToolButton;
    btnTraceLogLv: TToolButton;
    btn9: TToolButton;
    btn10: TToolButton;
    btnTaskStart: TButton;
    btnTaskStop: TButton;
    lblTrace: TLabel;
    btnRndParam: TButton;
    udTaskCount: TUpDown;
    edtTaskCount: TEdit;
    lbl6: TLabel;
    pnl5: TPanel;
    lbl7: TLabel;
    lbl8: TLabel;
    pbTotal: TProgressBar;
    pbTaskTerm: TProgressBar;
    rgRunOrder: TRadioGroup;
    rgRunMode: TRadioGroup;
    pnl6: TPanel;
    btn7: TButton;
    btn8: TButton;
    btn23: TButton;
    btn24: TButton;
    lbl9: TLabel;
    edtKeyWord: TEdit;
    lbl10: TLabel;
    edtPageNo: TEdit;
    udPageNo: TUpDown;
    pnl7: TPanel;
    grp6: TGroupBox;
    chklstWebEngine: TCheckListBox;
    tlb9: TToolBar;
    btn27: TToolButton;
    btn28: TToolButton;
    grp4: TGroupBox;
    lvSearch: TListView;
    actBeginSearch: TAction;
    actPauseSearch: TAction;
    actGoonSearch: TAction;
    actStopSearch: TAction;
    tlb3: TToolBar;
    btn11: TToolButton;
    btn12: TToolButton;
    btn13: TToolButton;
    mmMain: TMainMenu;
    N7: TMenuItem;
    procedure btnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure tkbPxyChange(Sender: TObject);
    procedure actLvPxyImportExecute(Sender: TObject);
    procedure actLvPxyExportExecute(Sender: TObject);
    procedure actLvPxyDelSelExecute(Sender: TObject);
    procedure actLvPxyDelFailExecute(Sender: TObject);
    procedure actLvPxyClearExecute(Sender: TObject);
    procedure btnGoonClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure lvPxyColumnClick(Sender: TObject; Column: TListColumn);
    procedure lvPxyCompare(Sender: TObject; Item1, Item2: TListItem;
      Data: Integer; var Compare: Integer);
    procedure actLvPxyResetExecute(Sender: TObject);
    procedure tkbTraceChange(Sender: TObject);
    procedure btnRndParamClick(Sender: TObject);
    procedure btnTaskStartClick(Sender: TObject);
    procedure btnTaskStopClick(Sender: TObject);
    procedure btn10Click(Sender: TObject);
    procedure btn9Click(Sender: TObject);
    procedure actBeginSearchExecute(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure actPauseSearchExecute(Sender: TObject);
    procedure actGoonSearchExecute(Sender: TObject);
    procedure actStopSearchExecute(Sender: TObject);
    procedure lvSearchDblClick(Sender: TObject);
    procedure btn27Click(Sender: TObject);
    procedure btn28Click(Sender: TObject);
    procedure btn11Click(Sender: TObject);
    procedure btn13Click(Sender: TObject);
    procedure N7Click(Sender: TObject);
  private
    ConfigIni : TIniFile;
    //
    DemoPool : TThreadPoolDemo;   //used in demo1
    //
    CheckProxyPool : TCheckProxyPool;    //used in demo2
    //
    WebSearchHolder : TWebSearchHolder;  //used in demo3
    //
    procedure DemoPoolLvTrace(Log : string; Row : Integer; Column : Byte; ImgIdx : SmallInt; Sender : TObject);
    procedure DemoPoolTrace(Log : string; Sender: TObject);
    procedure DemoPoolDone(Sender : TObject);
    procedure DemoPoolStop(Sender : TObject);
    //
    procedure CheckProxyPoolDone(Sender : TObject);
    procedure CheckProxyPoolStop(Sender : TObject);
    procedure CheckProxyPoolTrace(Log : string; Sender: TObject);
    procedure LvPxyTraceLog(Log : string; Row : Integer; Column : Byte; ImgIdx : SmallInt; Sender : TObject);
    //
    procedure WebSearchFind(Link,LinkText : string; PageNo : Integer; Engine : Byte; Sender : TObject);
    procedure WebSearchDone(Sender : TObject);
  public
    procedure SaveLvPxy(fn : string);
    procedure LoadLvPxy(fn : string);
    procedure PreStart;
    procedure SetTaskBtnStat(Stat : TBtnStat);
    procedure SetChkPxyTaskBtnStat(Stat : TBtnStat);
    procedure LockLvPxy(Lock : boolean);
    procedure LoadWebEngine;
    procedure SaveWebEngine;
  end;

var
  frmDemo: TfrmDemo;

implementation

uses
  HTTPutil;

{$R *.dfm}

procedure TfrmDemo.LvPxyTraceLog(Log : string; Row : Integer; Column : Byte; ImgIdx : SmallInt; Sender : TObject);
begin
  RfhLvItem(lvPxy,Log,Row,Column,False,False,ImgIdx);
end;

procedure TfrmDemo.WebSearchFind(Link,LinkText : string; PageNo : Integer; Engine : Byte; Sender : TObject);
var
  Subs : TStringList;
begin
  Subs := TStringlist.Create;
  try
    Subs.Add(Link);
    Subs.Add(LinkText);
    Subs.Add(IntToStr(PageNo+1));
    Subs.Add(WebEngineName[Engine]);
    AddLv(lvSearch,Subs);
  finally
    FreeAndNil(Subs);
  end;
end;

procedure TfrmDemo.WebSearchDone(Sender : TObject);
begin
  MsgBox('搜索任务已经全部完成！',0);
end;

procedure TfrmDemo.DemoPoolLvTrace(Log : string; Row : Integer; Column : Byte; ImgIdx : SmallInt; Sender : TObject);
begin
  RfhLvItem(lvTask,Log,Row,Column,False,False,ImgIdx);
end;

procedure TfrmDemo.DemoPoolTrace(Log : string; Sender: TObject);
var
  ThreadIndex,TaskIndex,strLog : string;
begin
  ThreadIndex := GetDigAt(Log,'THREAD',False);
  TaskIndex := GetDigAt(Log,'TASK',False);
  strLog := RStrDiv(Log,'LOG');
  if IsNum(strLog) then
  begin
    if btnTraceLog.Down then
    AddLstBPro(lstLog,Format('线程 %s 终止,任务号 %s ,延时 %s 毫秒',[ThreadIndex,TaskIndex,strLog]),True,2000);
  end;
  if btnTraceLogLv.Down then
  begin
    RfhLvItem(lvTrace,TaskIndex,StrToInt(ThreadIndex),1,False);
    if not IsNum(strLog) then
      RfhLvItem(lvTrace,strLog,StrToInt(ThreadIndex),2,False)
    else
      RfhLvItem(lvTrace,Format('延时 %s 毫秒',[strLog]),StrToInt(ThreadIndex),2,False);
  end;
end;

procedure TfrmDemo.SetChkPxyTaskBtnStat(Stat : TBtnStat);
begin
  btnStart.Enabled := ABtnEnab[Integer(Stat),Integer(btStart)];
  btnGoon.Enabled :=  ABtnEnab[Integer(Stat),Integer(btGoon)];
  btnStop.Enabled :=  ABtnEnab[Integer(Stat),Integer(btStop)];
end;

procedure TfrmDemo.SetTaskBtnStat(Stat : TBtnStat);
begin
  btnTaskStart.Enabled := ABtnEnab[Integer(Stat),Integer(btStart)];
//  btnTaskGoon.Enabled :=  ABtnEnab[Integer(Stat),Integer(btGoon)];
  btnTaskStop.Enabled :=  ABtnEnab[Integer(Stat),Integer(btStop)];
end;

procedure TfrmDemo.LockLvPxy(Lock : boolean);
begin
  lvPxy.Tag := BoolToInt(Lock);
  actLvPxyImport.Enabled := Lock;
  actLvPxyExport.Enabled := Lock;
  actLvPxyDelSel.Enabled := Lock;
  actLvPxyDelFail.Enabled := Lock;
  actLvPxyClear.Enabled := Lock;
  actLvPxyReset.Enabled := Lock;
end;

procedure TfrmDemo.LoadWebEngine;
var
  i : Byte;
  Obj : PWebEngineObj;
  b : boolean;
  Sets : TStringList;
  function ReadEngineSet: Boolean;
  var
    EngineSet : string;
  begin
    EngineSet := ConfigIni.ReadString('engine','check','err');
    Result := EngineSet <> 'err';
    ExtractStrings([','],[],PChar(EngineSet),Sets);
  end;
begin
  Sets := TStringList.Create;
  b := ReadEngineSet;
  for i:=0 to WEB_ENGINE_COUNT-1 do
  begin
    GetMem(Obj,SizeOf(TWebEngineObj));
    Obj.Site := TWebEngine(i);
    chklstWebEngine.Items.AddObject(WebEngineName[i],TObject(Obj));
    if not b then
      chklstWebEngine.Checked[i] := True
    else
      chklstWebEngine.Checked[i] := Sets.IndexOf(IntToStr(i))<>-1;
  end;
end;

procedure TfrmDemo.SaveWebEngine;
var
  i : Byte;
  EngineSet : string;
begin
  with chklstWebEngine do
  begin
    for i:=0 to Items.Count-1 do
    begin
      if Checked[i] then
      EngineSet := EngineSet + IntToStr(i) + ',';
    end;
  end;
  if EngineSet <> '' then
  Delete(EngineSet,Length(EngineSet),1);
  ConfigIni.WriteString('engine','check',EngineSet);
end;

procedure TfrmDemo.DemoPoolDone(Sender : TObject);
begin
  FreeAndNil(DemoPool);
  SetTaskBtnStat(bsNull);
  MsgBox('任务结束！',0);
end;

procedure TfrmDemo.DemoPoolStop(Sender : TObject);
var
  SuccIdx : Integer;
begin
  SuccIdx := -1;
  if DemoPool._SUCCESS_INDEX > 0 then
  SuccIdx := DemoPool._SUCCESS_INDEX;
  FreeAndNil(DemoPool);
  SetTaskBtnStat(bsNull);
  if SuccIdx > 0 then
  begin
    lvTask.Items[SuccIdx].MakeVisible(False);
    lvTask.Items[SuccIdx].Selected := True;
    MsgBox(Format('你选择了瞬死模式！，瞬死任务索引为 %d',[SuccIdx+1]),0);
  end else
    MsgBox('任务被强行终止，线程已释放！',0);
end;


procedure TfrmDemo.CheckProxyPoolDone(Sender : TObject);
begin
  FreeAndNil(CheckProxyPool);
  SetChkPxyTaskBtnStat(bsNull);
  LockLvPxy(True);
  MsgBox('^_^ 代理验证完毕！',0);
end;

procedure TfrmDemo.CheckProxyPoolStop(Sender : TObject);
begin
  FreeAndNil(CheckProxyPool);
  SetChkPxyTaskBtnStat(bsNull);
  LockLvPxy(True);
  MsgBox('p_p 所有线程已经安全终止！',0);
end;

procedure TfrmDemo.CheckProxyPoolTrace(Log : string; Sender: TObject);
begin
  stat.Panels[0].Text := Format(' -->%s',[Log]);
end;

procedure TfrmDemo.SaveLvPxy(fn : string);
begin
  eplstV(LvPxy,fn,':');
end;

procedure TfrmDemo.LoadLvPxy(fn : string);
var
  f : TextFile;
  S : String;
  Subs : TStringList;
begin
  try
    Assignfile(f, fn);
    Reset(f);
    Subs := TStringList.Create;
    try
      while not Eof(f) do
      begin
        Readln(F,S);
        Subs.Clear;
        Subs.Add(GetDigAt(s,':',TRUE)) ;
        Subs.Add(GetDigAt(s,':',FALSE)) ;
        Subs.Add('');
        Subs.Add('');
        AddLv(lvPxy,Subs,False,False);
      end;
    finally
      Subs.Free;
    end;
  finally
    CloseFile(f);
  end;
end;
12 下一页
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -