uparseren.pas

这是一个从指定网页格式分离单词的小程序

unit uParserEn;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, XPMan, ComCtrls, StdCtrls, ExtCtrls, DB, ADODB, Menus,
  ShellAPI, uConst, Grids, Spin, DateUtils, DBGrids;

const  CheckInterval = 600;  {2005-3-18 21:03:32 Add by Piao 刷新任务列表最短间隔}

       ShowICOInterval = 500; {2005-3-18 21:05:09 Add by Piao 显示图标最短间隔}

       ShowMsgInterval = 400; {2005-3-19 14:39:14 Add by Piao 显示信息最短间隔}

       MsgQueueLen = 1500; {2005-3-18 22:23:00 Add by Piao 消息队列长度}


type
  TFrmParseEnWord = class(TForm)
    pnl1: TPanel;
    lbl1: TLabel;
    edtURL: TEdit;
    btn1: TButton;
    StatusBarTask: TStatusBar;
    XPManifest1: TXPManifest;
    ADOConn: TADOConnection;
    ADOQtmp: TADOQuery;
    PopupMenuTask: TPopupMenu;
    CloseMenuClick: TMenuItem;
    OpenMenuClick: TMenuItem;
    StrGridLog: TStringGrid;
    ADOQScan: TADOQuery;
    Panel1: TPanel;
    Splitter1: TSplitter;
    Button2: TButton;
    Button1: TButton;
    AutoAddTaskTimer: TTimer;
    SpinEditMaxT: TSpinEdit;
    Button4: TButton;
    Label2: TLabel;
    PauseBtn: TButton;
    N1: TMenuItem;
    MenuPause: TMenuItem;
    Panel2: TPanel;
    Label1: TLabel;
    BtnScan: TButton;
    EnglishWordEdt: TEdit;
    Panel3: TPanel;
    DBGridEnglish: TDBGrid;
    DBGridChinese: TDBGrid;
    Splitter2: TSplitter;
    ADOQEnglish: TADOQuery;
    ADOQChinese: TADOQuery;
    DSEnglish: TDataSource;
    DSChinese: TDataSource;
    PopupMenuMsg: TPopupMenu;
    N2: TMenuItem;
    MenuShowCheckLast: TMenuItem;
    N4: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure CloseMenuClickClick(Sender: TObject);
    procedure btn1Click(Sender: TObject);
    procedure OpenMenuClickClick(Sender: TObject);
    procedure pnl1Resize(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure AutoAddTaskTimerTimer(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure PauseBtnClick(Sender: TObject);
    procedure BtnScanClick(Sender: TObject);
    procedure MenuPauseClick(Sender: TObject);
    procedure Panel2Resize(Sender: TObject);
    procedure ADOQEnglishAfterScroll(DataSet: TDataSet);
    procedure EnglishWordEdtKeyPress(Sender: TObject; var Key: Char);
    procedure MenuShowCheckLastClick(Sender: TObject);
    procedure N2Click(Sender: TObject);
  private
    { Private declarations }
    NDICO: PNotifyIconDataA;

    procedure TaskIcoMsgDo(var Msg:TMessage); Message WM_TaskICOForParser;
    procedure FormSysMsgDo(var Msg:TMessage); Message WM_SYSCOMMAND;
    procedure CheckTmpListMsg(var Msg:TMessage); Message WM_CheckTmpURLList;

    procedure InitLogGrid(sGrid: TStringGrid);
    procedure ShowLogMsg(sLog: string; SLevel: integer = 0);
  public
    { Public declarations }
    FShowGlobalMsg: Cardinal;//全局唤醒消息
    procedure WndProc(var Messages: TMessage); override;
  end;

var
  FrmParseEnWord: TFrmParseEnWord;
  RunPath: string;            //程序运行路径
  ShowAllMsg, ChangTaskICOED: boolean;        //是否显示全部信息
  AutoRefreshTaskNum: integer;//自动刷新任务列表次数
  StartTime: TDateTime;

  LastCheckLst: Cardinal;     //记录上次刷新任务的时间
  LastShowMsg: Cardinal;      //上次显示信息的时间
  LastShowICO: Cardinal;      //上次更改任务栏图标的时间

  StrMsg: array[0..MsgQueueLen] of string;//信息显示队列，解决当要显示的信息太多时造成界面无响应问题
  FrontMsgI, RearMsgI, CurMsgLen: integer;//信息队列的头尾位置
implementation

uses uPublic, uPaserWordThread;

{$R MyRes.RES} //引用的图标资源

{$R *.dfm}

procedure TFrmParseEnWord.FormCreate(Sender: TObject);
begin
  SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
  RunPath := ExtractFilePath(Application.ExeName);
  FMainForm := FrmParseEnWord.Handle;//避免循环引用单元
  FFaileTry := 3;                    //操作失败重试次数
  FMaxThreadNum := 1; {Add 2005-03-15 by Piao FMaxThreadNum 设置最大线程数目}
  SetLength(FThreadQueue, FMaxThreadNum); //分配队列
  AutoRefreshTaskNum := 5;                //当任务完成后自动检查一定次数后确定完成搜索
  AutoAddTaskTimer.Tag := 0;              //用AutoAddTaskTimer.Tag记录已经搜索的次数

  LastCheckLst := 0;     //记录上次刷新任务的时间
  LastShowMsg := 0;      //上次显示信息的时间

  {2005-3-18 22:38:33 Add by Piao 缓冲消息显示防止显示太快导致界面无响应}
  FrontMsgI := 0;        //队头
  RearMsgI := 0;         //队尾
  CurMsgLen := 0;        //实际队列长度

  AutoAddTaskTimer.Interval := ShowMsgInterval + 50;
  SpinEditMaxT.Value := FMaxThreadNum;
  try
    ADOConn.Close;
    FDataLinkStr := Format(SConnectionString,[RunPath + SNowPath + SAccessDBName]);
    ADOConn.ConnectionString := FDataLinkStr;
    ADOConn.LoginPrompt := False;
    ADOConn.Open;
    ADOQtmp.Connection := ADOConn;
    ADOQScan.Connection := ADOConn;
    FProDataQuery := ADOQtmp;//避免频繁创建
  except
    on E:Exception do
    begin
      Application.MessageBox(PAnsiChar('连接数据库失败!' + #13#10 + E.Message),
        '错误提示', MB_ICONSTOP or MB_OK);
      Application.Terminate;
    end;
  end;//try

  //SetWindowLong(FrmParseEnWord.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);

  ChangTaskICOED := False;
  New(NDICO);

  with NDICO^ do
  begin
    Wnd := FrmParseEnWord.Handle;
    uID := 0;
    uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
    hIcon := LoadIcon(HInstance,PAnsiChar('TASKONE'));
    //hIcon := Application.Icon.Handle;
    uCallbackMessage := WM_TaskICOForParser;
    szTip := '单词抓取测试版';
  end;

  if Not Shell_NotifyIcon(NIM_ADD, NDICO) then
  begin
    Application.MessageBox('注册任务栏图标失败！','提示！', MB_ICONSTOP or MB_OK);
    Application.Terminate;
  end;//if

  //ShowLogMsg('连接数据库成功!');
//  ExecADOQ('delete table from TTmpURLList',ADOQtmp);
//  ExecADOQ('delete table from TEnWordClass',ADOQtmp);
//  ExecADOQ('delete table from TEnglish',ADOQtmp);
//  ExecADOQ('delete table from TChinese',ADOQtmp);



  InitLogGrid(StrGridLog);//初始Log显示Grid

  FShowLogMsg := ShowLogMsg; //避免循环引用单元
  ShowAllMsg := False;       //默认情况下只显示错误消息
end;

procedure TFrmParseEnWord.FormDestroy(Sender: TObject);
begin
  SetLength(FThreadQueue, 0);
  ADOConn.Close;//关闭数据库连接

  Shell_NotifyIcon(NIM_DELETE, NDICO);
  Dispose(NDICO);
  FreeQueueMsg;
end;

procedure TFrmParseEnWord.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
var t: integer;
begin
  t := GetRunningThreadCount(FThreadQueue);
  if t > 0 then
  begin
    CanClose := Application.MessageBox(
      PChar('当前还有 ' + IntToStr(t) + ' 个任务在运行确定要退出？'),
      '询问', MB_ICONQUESTION or MB_OKCANCEL) = IDOK;
  end;//if

end;

procedure TFrmParseEnWord.TaskIcoMsgDo(var Msg: TMessage);
var MenuPopupIsPos: TPoint;
begin
  case Msg.LParam of
    WM_RBUTTONUP:
    begin
      GetCursorPos(MenuPopupIsPos);
      PopupMenuTask.Popup(MenuPopupIsPos.X, MenuPopupIsPos.Y);
    end;

    WM_LBUTTONUP:
    begin
      if FrmParseEnWord.Showing then
      begin
        FrmParseEnWord.Hide;
      end
      else
      begin
        FrmParseEnWord.Show;
        SetForegroundWindow(FrmParseEnWord.Handle);
      end; //if
    end;
  else
    inherited;
  end;//case

end;


procedure TFrmParseEnWord.FormSysMsgDo(var Msg: TMessage);
begin
  case Msg.WParam of
    SC_MINIMIZE, SC_CLOSE:
    begin
      FrmParseEnWord.Hide;
    end;
  else
    inherited;
  end;//case
end;

procedure TFrmParseEnWord.CloseMenuClickClick(Sender: TObject);
begin
  Close;
end;

procedure TFrmParseEnWord.btn1Click(Sender: TObject);
var NewTask: PThreadTask;
    NewTaskID: integer;
    i, t: integer;
    QOK: boolean;
begin
  QOK := True;
  if Length(FPQueueMsg) = 0 then
  begin
    i := GetCountCondition('FURL','TEnWordClass','FType=0',ADOQtmp);//获取未完成的链接
    t := GetCountCondition('FURL','TTmpURLList','FType=0',ADOQtmp);//获取临时抓取的链接
    if (i > 0) or (t > 0) then
    begin
      //Application.MessageBox('是否继续上次的抓取任务？', '询问', MB_ICONQUESTION or MB_OKCANCEL)
      ExecADOQ('update TEnWordClass set FType=0 where FType=2 ',ADOQtmp);
      ExecADOQ('update TTmpURLList set FType=0 where FType=2 ',ADOQtmp);
      SendMessage(FrmParseEnWord.Handle,WM_CheckTmpURLList,0,0);//发送更新相似页面消息
    end
    else
    begin
      i := GetCountCondition('FURL','TEnWordClass','FType=3',ADOQtmp);//获取未完成的链接
      t := GetCountCondition('FURL','TTmpURLList','FType=3',ADOQtmp);//获取临时抓取的链接
      if (i > 0) or (t > 0) then
      begin
        QOK := Application.MessageBox(PChar('抓取任务已经完成！'#13#10 +
          '确定重新搜索？'), '提示',MB_ICONQUESTION or MB_OKCANCEL) = IDOK;
        if not QOK then
        ShowLogMsg('抓取任务已经完成，要重新搜索请清空数据！',3);
      end;//if
    end;//if
  end;//if
  if QOK then
  begin
    ExecADOQ('update TEnWordClass set FType=0 ',ADOQtmp);
    ExecADOQ('update TTmpURLList set FType=0 ',ADOQtmp);

    NewTaskID := Length(FPQueueMsg) + 1;
    New(NewTask);
    with NewTask^ do
    begin
      sName := '抓取页面' + IntToStr(NewTaskID);
      sURL := Trim(edtURL.Text);
      sFileName := GetTempPathFileName;
      //sFileName := 'c:\MyHtml0' + IntToStr(NewTaskID) + '.Html';
      TaskType := 0;     //0 下载文件
      OnComplete := nil; //完成后处理的事件
      TaskStatus := tsCreate; //标识为新建立的任务
    end;//with
    if AddTaskMsg(NewTask) then
    begin
      ShowLogMsg('添加 ' + NewTask^.sName + ' 任务成功!');
      NewTask^.TaskStatus := tsWait; //标识为等待处理的任务
      ProWaitQueue;//处理所有处于等待状态的任务
      StartTime := Now();
      ShowLogMsg('开始抓取数据！' + FormatDateTime('yyyy-mm-dd hh:mm:ss',StartTime),1);
    end;
  end;//if

//  CreateToolTips(FrmParseEnWord.Handle);
//  AddToolTip(FrmParseEnWord.Handle, @ti, 1, '提示内容', '提示标题',0,0);
end;

procedure TFrmParseEnWord.OpenMenuClickClick(Sender: TObject);
begin
  FrmParseEnWord.Show;
  SetForegroundWindow(FrmParseEnWord.Handle);
end;

procedure TFrmParseEnWord.pnl1Resize(Sender: TObject);
begin
  edtURL.Width := pnl1.Width - 150;
end;

procedure TFrmParseEnWord.InitLogGrid(sGrid: TStringGrid);
begin
  with sGrid do
  begin
    ColCount := 2;
    RowCount := 2;
    FixedRows := 1;
    FixedCols := 1;
    ColWidths[0] := 30;
    Cells[0,0] := '编号';
    Tag := 0; //用于标识Log信息数量
  end;//with
end;

procedure TFrmParseEnWord.FormResize(Sender: TObject);
begin
  with StrGridLog do
  begin//动态改变列宽
    ColWidths[1] := Width - ColWidths[0] - 8;
  end;//with
end;

procedure TFrmParseEnWord.ShowLogMsg(sLog: string; SLevel: integer = 0);
var t, i, RuningT, WaitQueue: integer;
begin
  RuningT := GetRunningThreadCount(FThreadQueue);//获取当前运行的线程数目