upublic.~pas

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

{-----------------------------------------------------------------------------
 Unit Name: uPublic
 Author:    Piao
 Date:      2005-3-12 14:44:58
 Purpose:   公共函数单元
 History:
   2005-3-17 21:05:50 Add by Piao
   通过CurTaskThreadID修正TThread对象自动释放没有置nil问题

-----------------------------------------------------------------------------}

unit uPublic;

interface

uses ADODB, Windows, SysUtils, Classes, CommCtrl, Graphics, Messages, DB, IDURI, Forms;

const
  TTS_BALLOON    = $40;
  TTM_SETTITLE = (WM_USER + 32);

type
  {Add 2005-03-15 by Piao
   任务状态信息：
   tsCreate 新建立
   tsWait 在队列中等待
   tsRunning 正在运行
   tsDownFile 下载文件中
   tsPLink 抓取链接中
   tsParser 解析单词中
   tsComplete 完成
   tsError 处理出错状态
  }
  TTaskStatus = (tsCreate, tsWait, tsRunning, tsDownFile, tsPLink, tsParser, tsComplete, tsError);

type
  TCompleteEvent = procedure(TaskID: integer) of object;   //完成线程事件
  TShowLogEvent = procedure(sLog: string; SLevel: integer = 0) of object;       //显示Logs信息事件

  PThreadTask = ^TThreadTask;        //线程任务信息
  TThreadTask = record
    sName: string;                   //任务名称
    sURL: string;                    //任务处理的URL信息
    sFileName: string;               //任务处理的文件信息
    TaskType: integer;               //任务类型
    TaskStatus: TTaskStatus;         //任务当前状态，辅助控制用
    CurTaskThreadID: integer;        //当前任务线程的队列编号
    OnComplete: TCompleteEvent;      //完成任务后处理事件
  end;//TThreadTask

function OpenADOQ(sSQL: string; ADOQ: TADOQuery): boolean;

function ExecADOQ(sSQL: string; ADOQ: TADOQuery): boolean;

function GetCountCondition(FieldName,nTableName,Condition: string;
   ADOQ: TADOQuery; IsMaxed: boolean = False): integer;

function GetTempPathFileName:string;//取得临时文件名

{-----------------------------------------------------------------------------
  function: ParserHref
  Author:    Piao
  Date:      2005-3-13 20:49:16
  Arguments: ps: string 要转换的 href='article_view.asp?id=1184'
  Result:    string 转换为 article_view.asp?id=1184
-----------------------------------------------------------------------------}
function ParserHref(ps: string): string;

{-----------------------------------------------------------------------------
  Function: FreeThreadFromQueue
  Author:    Piao
  Date:      2005-03-15
  Arguments: FQueue: array of TThread线程队列
  Result:    integer
  Purpose:   获取空闲线程
-----------------------------------------------------------------------------}
function FreeThreadFromQueue(const FQueue: array of TThread): integer;

{-----------------------------------------------------------------------------
  Function: GetRunningThreadCount
  Author:    Piao
  Date:      2005-03-15
  Arguments: const FQueue: array of TThread
  Result:    integer
  Purpose:  获取正在运行的线程数目
-----------------------------------------------------------------------------}
function GetRunningThreadCount(const FQueue: array of TThread): integer;

{-----------------------------------------------------------------------------
  Function: AddTaskMsg
  Author:    Piao
  Date:      2005-03-15
  Arguments: TaskMsg: PThreadTask
  Result:    boolean              如果有重复则返回False
  Purpose: 把任务添加到队列中
-----------------------------------------------------------------------------}
function AddTaskMsg(TaskMsg: PThreadTask): boolean;

procedure CreateToolTips(hWnd: Cardinal);

procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer;
  Text, Title: PChar; BackColor,TextColor:TColor);

{-----------------------------------------------------------------------------
  Procedure: ProWaitQueue
  Author:    Piao
  Date:      2005-3-15 21:48:27
  Arguments: None
  Result:    从FPQueueMsg中取出等待的任务进行操作
-----------------------------------------------------------------------------}
procedure ProWaitQueue;

{-----------------------------------------------------------------------------
  Procedure: ProOnDownOver
  Author:    Piao
  Date:      2005-3-15 22:04:07
  Arguments: TaskID任务ID, tMsgParam处理信息: integer
  Result:    下载任务完成后处理的事件
-----------------------------------------------------------------------------}
procedure ProOnDownOver(TaskID, tMsgParam: integer);

{-----------------------------------------------------------------------------
  Procedure: ProOnParserTypeOver
  Author:    Piao
  Date:      2005-3-15 22:47:35
  Arguments: TaskID, tMsgParam: integer
  Result:    抓取页面可用链接完成后事件
-----------------------------------------------------------------------------}
procedure ProOnParserTypeOver(TaskID, tMsgParam: integer);

{-----------------------------------------------------------------------------
  Procedure: ProOnPaserWordOver
  Author:    Piao
  Date:      2005-3-16 2:30:50
  Arguments: TaskID, tMsgParam: integer
  Result:    分析单词页面后处理事件
-----------------------------------------------------------------------------}
procedure ProOnPaserWordOver(TaskID, tMsgParam: integer);

{-----------------------------------------------------------------------------
  Function: PauseThread
  Author:    Piao
  Date:      2005-03-16
  Arguments: FQueue: array of TThread;线程队列 Paused: boolean 为True时暂时，否则激活
  Result:    integer 返回成功暂停的线程数目
  Purpose:   暂定线程
-----------------------------------------------------------------------------}
function PauseThread(FQueue: array of TThread; Paused: boolean): integer;

{-----------------------------------------------------------------------------
  function: KillQueueThread
  Author:    Piao
  Date:      2005-3-16 19:30:37
  Arguments: FQueue: array of TThread
  Result:    integer      返回杀掉的线程
-----------------------------------------------------------------------------}
function KillQueueThread(FQueue: array of TThread): integer;

{-----------------------------------------------------------------------------
  Procedure: FreeQueueMsg
  Author:    Piao
  Date:      2005-3-16 20:56:41
  Arguments: None
  Result:    None清空任务信息队列
-----------------------------------------------------------------------------}
procedure FreeQueueMsg;

{-----------------------------------------------------------------------------
  Procedure: okDelay
  Author:    Piao
  Date:      2005-3-17 22:58:37
  Arguments: msecs: integer
  Result:    能处理消息的延时函数
-----------------------------------------------------------------------------}
procedure okDelay(msecs: Cardinal);

{-----------------------------------------------------------------------------
  function: StatusTaskCount
  Author:    Piao
  Date:      2005-3-19 11:59:11
  Arguments: CurStatus: TTaskStatus任务状态
  Result:    integer  返回已经某状态的任务数量
-----------------------------------------------------------------------------}
function StatusTaskCount(CurStatus: TTaskStatus): integer;

{Add 2005-03-15 by Piao 增加全局控制变量}
var FPQueueMsg: array of PThreadTask; //线程任务信息
    FThreadQueue: array of TThread;   //线程队列
    //FThreadHandleQ: array of Cardinal;//存放线程句柄信息

    FMaxThreadNum: integer;           //最大线程数目
    FShowLogMsg: TShowLogEvent;       //显示Logs事件
    FMainForm: THandle;               //主窗体句柄
    FFaileTry: integer;               //失败重试次数
    FDataLinkStr: string;             //全局数据库连接字串
    FProDataQuery: TADOQuery;         //可引用MainForm，避免频繁创建
    hToolTip: Cardinal;
    ti: TToolInfo;
implementation

uses uDownFileThread, uParserTypeThread, uConst, uPaserWordThread;

function OpenADOQ(sSQL: string; ADOQ: TADOQuery): boolean;
var i: integer;
begin
  for i := 0 to FFaileTry - 1 do
  begin//因为在多线操作时可以引起更新锁，重试几次增加成功率
    Result := True;
    try
      with ADOQ do
      begin
        Close;
        SQL.Clear;
        SQL.Add(sSQL);
        Open;
      end;//with
    except
      Result := False;
    end;//try
    if Result then Break
    else
      Sleep(1);
  end;// for i
end;

function ExecADOQ(sSQL: string; ADOQ: TADOQuery): boolean;
var i: integer;
begin
  for i := 0 to FFaileTry - 1 do
  begin//因为在多线操作时可以引起更新锁，重试几次增加成功率
    Result := True;
    try
      with ADOQ do
      begin
        Close;
        SQL.Clear;
        SQL.Add(sSQL);
        //Prepared;
        ExecSQL;
      end;//with
    except
      Result := False;
    end;//try
    if Result then
      Break
    else
      Sleep(1);
  end;// for i
end;


function GetCountCondition(FieldName,nTableName,Condition: string;
   ADOQ: TADOQuery; IsMaxed: boolean = False): integer;
var tmpS: string;
begin
  Result := -1;
  if IsMaxed then tmpS := 'Max' else tmpS := 'Count';
  if OpenADOQ('select ' + tmpS + '(' + FieldName +
    ') as ResultCount from ' + nTableName +
    ' where ' + Condition,ADOQ) then
  begin
    if ADOQ.Fields[0] is TIntegerField then  //安全第一
    Result := ADOQ.Fields[0].AsInteger;
  end;//if
end;

function GetTempPathFileName:string;//取得临时文件名
var SPath,Sfile: array [0..254] of Char;
begin
  GetTempPath(254, SPath);
  GetTempFileName(SPath, '~DL', 0, SFile);
  Result := SFile;
  DeleteFile(Result);
end;

function ParserHref(ps: string): string;
var sLen, sStart,sCount: integer;
  function CutOf(a: char): integer;
  begin
    if (a = '''') or (a = '"') then
      Result := 1
    else
      Result := 0;
  end;
begin
  ps := Trim(ps);
  sLen := Length(ps);
  Result := '';
  if sLen > 5 then
  begin
    sStart := 6 + CutOf(ps[6]);
    sCount := sLen - CutOf(ps[sLen]) - sStart + 1;
    Result := Copy(ps,sStart,sCount);
  end;//if
end;

function FreeThreadFromQueue(const FQueue: array of TThread): integer;
var i, QueueLen: integer;
    tStatus: Cardinal;
begin
  Result := -1;//表示队列己满

  QueueLen := High(FQueue);
  if ((FMaxThreadNum - 1)< QueueLen) and (FMaxThreadNum > 0) then
  begin//确保限制最大线程数目时得到有效控制
    QueueLen := FMaxThreadNum;
  end;//if
  for i := Low(FQueue) to QueueLen do
  begin
    if Assigned(FQueue[i]) then
    begin//如果对象不为Nil
      if GetExitCodeThread(FQueue[i].Handle,tStatus) then
      begin
        if tStatus <> STILL_ACTIVE then
        begin//如果当前线程状态不是激活的则干掉
          Result := i;
          Break;
        end;//if
      end
      else
      begin
        Result := i;
        Break;
      end;//if GetExitCodeThread
    end
    else
    begin//对象为Nil则直接返回
      Result := i;
      Break;
    end;//if Assigned
  end;// for i
end;

function GetRunningThreadCount(const FQueue: array of TThread): integer;
var i: integer;
    tStatus: Cardinal;
begin
  Result := 0;
  for i := Low(FQueue) to High(FQueue) do
  begin
    if Assigned(FQueue[i]) then
    begin
      if GetExitCodeThread(FQueue[i].Handle,tStatus) then
      begin
        if tStatus = STILL_ACTIVE then
        begin
          inc(Result);
        end;//if
      end;//if
    end;//if
  end;//for i
end;

function AddTaskMsg(TaskMsg: PThreadTask): boolean;
var i: integer;
begin
  Result := True;
  for i := Low(FPQueueMsg) to High(FPQueueMsg) do
  begin
    with FPQueueMsg[i]^ do
    if SameText(sURL, TaskMsg^.sURL) or
      SameText(sFileName, TaskMsg^.sFileName) then