upublic.~pas

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

    begin//URL或者临时文件重复则添加失败
      Result := False;
      //FShowLogMsg('相同的任务(' + sName  + ')已经在队列中...');
      Break;
    end;
  end;//for i
  if Result then
  begin
    i := Length(FPQueueMsg);
    SetLength(FPQueueMsg, i + 1);
    FPQueueMsg[i] := TaskMsg;
    TaskMsg^.TaskStatus := tsWait;   //将状态置为等待
    Result := True;
  end;//if
end;

procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
   Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
 if hToolTip <> 0 then
 begin
   SetWindowPos(hToolTip, HWND_TOPMOST, 0,0, 0, 0, SWP_NOMOVE or  SWP_NOSIZE or SWP_NOACTIVATE);
   ti.cbSize := SizeOf(TToolInfo);
   ti.uFlags := TTF_SUBCLASS or TTF_TRANSPARENT;
   ti.hInst := hInstance;
 end;
end;

procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar;
 BackColor,TextColor:TColor);
 //BackColor,TextColor分别是背景颜色和文本颜色,如果是0则取默认值.
var Rect: TRect;
    Buffer: array[0..255] of char;
begin
  if (hwnd <> 0) and (GetClientRect(hwnd, Rect)) then
  begin
    lpti.hwnd := hwnd;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(Buffer, Sizeof(Buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then IconType := 0;
    if BackColor<>0 then SendMessage(hToolTip, TTM_SETTIPBKCOLOR, BackColor, 0);
    if TextColor<>0 then SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, TextColor, 0);
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure ProWaitQueue;
var QueueTaskID, TaskThreadID: integer;
    PURI: TIdURI;//分析URL路径信息
    URLPath, WordClassID: string;
begin
  for QueueTaskID := Low(FPQueueMsg) to High(FPQueueMsg) do
  begin{注意}
    TaskThreadID := FreeThreadFromQueue(FThreadQueue);//获取空闲线程
    if TaskThreadID = -1 then Break; //队列满则退出
    with FPQueueMsg[QueueTaskID]^ do
    if TaskStatus = tsWait then
    begin//处理正在等待的任务
      CurTaskThreadID := TaskThreadID;//保存任务线程ID在完成时置为nil
      case TaskType of
        -1, 0: {下载任务,}
        begin
          if TaskType = -1 then
          begin
            TaskType := 5; //跳过解析可用链接，直接分析单词
            ExecADOQ('Update TEnWordClass Set FType = 1 where FURL=''' +
              sURL + '''',FProDataQuery);//标识此页面处理完毕
          end
          else
          begin
            if GetCountCondition('FURL','TTmpURLList',
              'FURL = ''' + sURL + '''',FProDataQuery) = 0 then
            begin//找不到则插入，避免重复处理
              ExecADOQ('insert into TTmpURLList(FName,FURL,FType) ' +
                ' values(''' + sName + ''',''' +
                 sURL + ''',1)',FProDataQuery);
            end;//if
          end;//if


          FThreadQueue[TaskThreadID] := TDownFileThread.Create(sURL,
            sFileName, FMainForm, FFaileTry, QueueTaskID, False);
          TaskStatus := tsDownFile; //将任务状态置为下载文件
          FShowLogMsg(sName + '：正在下载数据...');
        end;
        1: {解析页面可用链接}
        begin
          PURI := TIdURI.Create(sURL);
          if SameText(PURI.Protocol,'http') then
          begin
            URLPath := PURI.Protocol + '://' + PURI.Host + PURI.Path;
            FThreadQueue[TaskThreadID] := TParserTypeThread.Create(FDataLinkStr,
              URLPath,sFileName,FMainForm,QueueTaskID,False);
            TaskStatus := tsPLink;{将任务状态置为解析可用链接}
            FShowLogMsg(sName + '：正在分析页面可用链接...');
          end
          else
          begin
            FShowLogMsg(sName + '：URL信息不正确，必须为http协议!');
          end;//if
        end;
        6: {分析页面中的单词}
        begin
          if OpenADOQ('select FID from TEnWordClass where FURL=''' +
            sURL + '''',FProDataQuery) then
          if FProDataQuery.RecordCount = 1 then
          begin//找到对应的页面链接才分析
            WordClassID := FProDataQuery.Fields[0].AsString;
            if FileExists(sFileName) then
            begin//如果文件存在
              ExecADOQ('Update TEnWordClass Set FType = 2 where FURL=''' +
                sURL + '''',FProDataQuery);//标识此页面正在处理

              FThreadQueue[TaskThreadID] := TPaserWordThread.Create(FDataLinkStr,
                sFileName,WordClassID,FMainForm,QueueTaskID,False);

              TaskStatus := tsParser; {将任务状态置为分析页面单词}
            end;//if
          end;//if
        end;
      else//当没有可处理的状态时将任务置为完成
        TaskStatus := tsComplete;
        if FileExists(sFileName) then
        begin//删除临时文件
          DeleteFile(sFileName);
        end;//if
        FShowLogMsg(sName + '：处理完毕!',110);
      end;//case
    end;
  end;//for i
end;

procedure ProOnDownOver(TaskID, tMsgParam: integer);
begin
  if (TaskID >= Low(FPQueueMsg)) and (TaskID <= High(FPQueueMsg)) then
  begin//如果任务存在
    with FPQueueMsg[TaskID]^ do
    begin
      case tMsgParam of
        0: {下载完成!}
        begin
          FShowLogMsg(sName + '：下载数据成功!',1);

          if Assigned(OnComplete) then
          begin//处理任务完成后的事件
            OnComplete(TaskID);
          end;//if
          ExecADOQ('Update TTmpURLList Set FType = 2 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面正等待处理

          TaskType := TaskType + 1;{改变任务类型}
          TaskStatus := tsWait;    {加入等待队列}

        end;
        1: {下载失败}
        begin
          FShowLogMsg(sName + '：下载数据失败!',1);
          TaskStatus := tsError;
        end;
      else
        FShowLogMsg('下载模块收到来自 ' + IntToStr(TaskID) + ' 的无效消息!',1);
      end;//case
      FThreadQueue[CurTaskThreadID] := nil;
    end;//with FPQueueMsg
  end;//if
  ProWaitQueue;
end;

procedure ProOnParserTypeOver(TaskID, tMsgParam: integer);
begin
  if (TaskID >= Low(FPQueueMsg)) and (TaskID <= High(FPQueueMsg)) then
  begin//如果任务存在
    with FPQueueMsg[TaskID]^ do
    begin
      case tMsgParam of
        0: {成功分析可用链接完成!}
        begin
          FShowLogMsg(sName + '：分析可用链接完毕!',3);
          if Assigned(OnComplete) then
          begin//处理任务完成后的事件
            OnComplete(TaskID);
          end;//if
          ExecADOQ('Update TTmpURLList Set FType = 3 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面处理完毕

          TaskType := TaskType + 1;{改变任务类型}
          TaskStatus := tsWait;    {加入等待队列}

        end;
        1: {分析可用链接失败}
        begin
          FShowLogMsg(sName + '：分析可用链接失败!',1);
          TaskStatus := tsError;
          ExecADOQ('Update TTmpURLList Set FType = -3 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面处理失败

        end;
      else
        FShowLogMsg('搜索可用链接模块收到来自 ' + IntToStr(TaskID) + ' 的无效消息!',1);
      end;//case
      FThreadQueue[CurTaskThreadID] := nil;
    end;//with FPQueueMsg
  end;//if
  ProWaitQueue;
end;

procedure ProOnPaserWordOver(TaskID, tMsgParam: integer);
begin
  if (TaskID >= Low(FPQueueMsg)) and (TaskID <= High(FPQueueMsg)) then
  begin//如果任务存在
    with FPQueueMsg[TaskID]^ do
    begin
      case tMsgParam of
        0: {成功分离页面单词!}
        begin
          FShowLogMsg(sName + '：分离页面单词完毕!',3);
          if Assigned(OnComplete) then
          begin//处理任务完成后的事件
            OnComplete(TaskID);
          end;//if

          ExecADOQ('Update TEnWordClass Set FType = 3 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面处理完毕

          TaskType := TaskType + 1;{改变任务类型}
          TaskStatus := tsWait;    {加入等待队列}

        end;
        1: {分离页面单词失败}
        begin
          FShowLogMsg(sName + '：分离页面单词失败!',1);
          TaskStatus := tsError;
          ExecADOQ('Update TEnWordClass Set FType = -3 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面处理失败
        end;
        -7:
        begin
          FShowLogMsg(sName + '：分离页面单词严重错误未知失败!',1);
          TaskStatus := tsError;
          ExecADOQ('Update TEnWordClass Set FType = -3 where FURL=''' +
            sURL + '''',FProDataQuery);//标识此页面处理失败

        end;
      else
        FShowLogMsg('分离中英文单词模块收到来自 ' + IntToStr(TaskID) + ' 的无效消息!',1);
      end;//case
      FThreadQueue[CurTaskThreadID] := nil;
    end;//with
  end;//if
  ProWaitQueue;
end;

function PauseThread(FQueue: array of TThread; Paused: boolean): integer;
var i: integer;
    tStatus: Cardinal;
begin
  Result := 0;//表示队列己满
  for i := Low(FQueue) to High(FQueue) do
  begin
    if Assigned(FQueue[i]) then
    begin//如果对象不为Nil
      if GetExitCodeThread(FQueue[i].Handle,tStatus) then
      begin
        if tStatus = STILL_ACTIVE then
        begin//如果当前线程状态不是激活的则干掉
          if Paused then
          begin//如果要挂起线程
            if not FQueue[i].Suspended then FQueue[i].Suspend;
          end
          else
          begin//激活线程
            if FQueue[i].Suspended then FQueue[i].Resume;
          end;//if
          inc(Result);
        end;//if
      end;
//      else
//      begin//对于不处于激活状态的全部干掉
//        FQueue[i].Terminate;
//        FQueue[i].Suspend;
//        FQueue[i].Free;
//        FQueue[i] := nil;
//      end;//if
    end;//if
  end;//for i
  {Add 2005-03-16 by Piao 暂时不这样处理}
//  if Paused then
//  begin//将线程排序，这样可以动态调整最大线程数目
//    for i := Low(FQueue) to High(FQueue) do
//    begin
//
//    end;//for i
//  end;//if
end;

function KillQueueThread(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//如果对象不为Nil
      if GetExitCodeThread(FQueue[i].Handle,tStatus) then
      begin
        if tStatus = STILL_ACTIVE then
        begin//如果当前线程状态不是激活的则干掉
          FQueue[i].Terminate;
          FQueue[i].Suspend;
          FQueue[i].Free;
          FQueue[i] := nil;
          inc(Result);
        end;
      end;
    end;//if
  end;//for i
end;

procedure FreeQueueMsg;
var i: integer;
begin
  for i := Low(FPQueueMsg) to High(FPQueueMsg) do
  begin
    Dispose(FPQueueMsg[i]);
  end;//for i
  SetLength(FPQueueMsg, 0);
end;

procedure okDelay(msecs: Cardinal);
var FirstTickCount: Cardinal;
begin
  FirstTickCount := GetTickCount;
  repeat
    Application.ProcessMessages;
  until ((GetTickCount - FirstTickCount) >= msecs);
end;

function StatusTaskCount(CurStatus: TTaskStatus): integer;
var i: integer;
begin
  Result := 0;
  for i := Low(FPQueueMsg) to High(FPQueueMsg) do
  begin
    with FPQueueMsg[i]^ do
    begin
      if TaskStatus = CurStatus then
      begin
        inc(Result);
      end;//if
    end;//with
  end;//for i
end;


end.