delphi 如何判断应用程序未响应

http://www.cnblogs.com/smallmuda/archive/2009/07/24/1529845.html

delphi 如何判断应用程序未响应

 

 今天在MSN的核心讨论组上看到两篇文章.讨论的乃是应用程序是否没有响应.原文如下:     
    
  >   How   is   it   possible   to   determine   a   process   is   "not   responding"   like   NT   Task     
  >   Manager   do?     
  The   heuristic   works   only   for   GUI   processes,   and   consists   of   calling     
  SendMessageTimeOut()   with   SMTO_ABORTIFHUNG.     
    
  >There   is   any   API   call   to   do   the   job,   or   this   status   is   simply   a   deduction     
  >based   on   process   counters,   like   that   returned   from   call   to   GetProcessTimes     
  >API   function?     
    
  Use   SendMessageTimeout   with   a   value   of   WM_NULL.   That's   all   Task     
  Manager   does   to   determine   this   AFAIK.     
    
  --     
  有理有理.当然,我这里还有一个UNDOCUMENTED函数,乃是其他的解决方案,NT和9X有个USER32.DLL的函数,IsHungAppWindow(NT)和IsHungThread(9X).使用起来简便无比.下面给出原型.     
  BOOL   IsHungAppWindow   (     
  HWND   hWnd,   //   handle   to   main   app's   window     
  );     
    
  BOOL   IsHungThread   (     
  DWORD   dwThreadId,   //   The   thread's   identifier   of   the   main   app's   window     
  );     
  有了原型,连解释都不需要,好得不的了.:)不过调用时需要GetProcAddress.库里没有该函数.     
  ****************************************   
  check   whether   an   application   (window)   is   not   responding?   
    
  {1.   The   Documented   way}     
    
  {     
      An   application   can   check   if   a   window   is   responding   to   messages   by     
      sending   the   WM_NULL   message   with   the   SendMessageTimeout   function.     
  }     
    
  function   AppIsResponding(ClassName:   string):   Boolean;     
  const     
      {   Specifies   the   duration,   in   milliseconds,   of   the   time-out   period   }     
      TIMEOUT   =   50;     
  var     
      Res:   DWORD;     
      h:   HWND;     
  begin     
      h   :=   FindWindow(PChar(ClassName),   nil);     
      if   h   <>   0   then     
          Result   :=   SendMessageTimeOut(H,     
              WM_NULL,     
              0,     
              0,     
              SMTO_NORMAL   or   SMTO_ABORTIFHUNG,     
              TIMEOUT,     
              Res)   <>   0     
      else     
          ShowMessage(Format('%s   not   found!',   [ClassName]));     
  end;     
    
  procedure   TForm1.Button1Click(Sender:   TObject);     
  begin     
      if   AppIsResponding('OpusApp')   then     
          {   OpusApp   is   the   Class   Name   of   WINWORD.EXE   }     
          ShowMessage('App.   responding');     
  end;     
    
  {2.   The   Undocumented   way}     
    
  {     
      //   Translated   form   C   to   Delphi   by   Thomas   Stutz     
      //   Original   Code:     
      //   (c)1999   Ashot   Oganesyan   K,   SmartLine,   Inc     
      //   mailto:ashot@aha.ru,   http://www.protect-me.com,   http://www.codepile.com     
    
    The   code   doesn't   use   the   Win32   API   SendMessageTimout   function   to     
    determine   if   the   target   application   is   responding   but   calls     
    undocumented   functions   from   the   User32.dll.     
    
    -->   For   Windows   95/98/ME   we   call   the   IsHungThread()   API     
    
    The   function   IsHungAppWindow   retrieves   the   status   (running   or   not   responding)     
    of   the   specified   application     
    
    IsHungAppWindow(Wnd:   HWND):   //   handle   to   main   app's   window     
    BOOL;     
    
    -->   For   NT/2000/XP   the   IsHungAppWindow()   API:     
    
    The   function   IsHungThread   retrieves   the   status   (running   or   not   responding)   of     
    the   specified   thread     
    
    IsHungThread(DWORD   dwThreadId):   //   The   thread's   identifier   of   the   main   app's   window     
    BOOL;     
    
    Unfortunately,   Microsoft   doesn't   provide   us   with   the   exports   symbols   in   the     
    User32.lib   for   these   functions,   so   we   should   load   them   dynamically   using   the     
    GetModuleHandle   and   GetProcAddress   functions:     
  }     
    
  //   For   Win9X/ME     
  function   IsAppRespondig9X(dwThreadId:   DWORD):   Boolean;     
  type     
      TIsHungThread   =   function(dwThreadId:   DWORD):   BOOL;   stdcall;     
  var     
      hUser32:   THandle;     
      IsHungThread:   TIsHungThread;     
  begin     
      Result   :=   True;     
      hUser32   :=   GetModuleHandle('user32.dll');     
      if   (hUser32   >   0)   then     
      begin     
          @IsHungThread   :=   GetProcAddress(hUser32,   'IsHungThread');     
          if   Assigned(IsHungThread)   then     
          begin     
              Result   :=   not   IsHungThread(dwThreadId);     
          end;     
      end;     
  end;     
    
  //   For   Win   NT/2000/XP     
  function   IsAppRespondigNT(wnd:   HWND):   Boolean;     
  type     
      TIsHungAppWindow   =   function(wnd:hWnd):   BOOL;   stdcall;     
  var     
      hUser32:   THandle;     
      IsHungAppWindow:   TIsHungAppWindow;     
  begin     
      Result   :=   True;     
      hUser32   :=   GetModuleHandle('user32.dll');     
      if   (hUser32   >   0)   then     
      begin     
          @IsHungAppWindow   :=   GetProcAddress(hUser32,   'IsHungAppWindow');     
          if   Assigned(IsHungAppWindow)   then     
          begin     
              Result   :=   not   IsHungAppWindow(wnd);     
          end;     
      end;     
  end;     
    
  function   IsAppRespondig(Wnd:   HWND):   Boolean;     
  begin     
    if   not   IsWindow(Wnd)   then     
    begin     
        ShowMessage('Incorrect   window   handle!');     
        Exit;     
    end;     
    if   Win32Platform   =   VER_PLATFORM_WIN32_NT   then     
        Result   :=   IsAppRespondigNT(wnd)     
    else     
        Result   :=   IsAppRespondig9X(GetWindowThreadProcessId(Wnd,nil));     
  end;     
    
  //   Example:   Check   if   Word   is   hung/responding     
    
  procedure   TForm1.Button3Click(Sender:   TObject);     
  var     
      Res:   DWORD;     
      h:   HWND;     
  begin     
      //   Find   Word   by   classname     
      h   :=   FindWindow(PChar('OpusApp'),   nil);     
      if   h   <>   0   then     
      begin     
          if   IsAppRespondig(h)   then     
              ShowMessage('Word   is   responding!')     
          else     
              ShowMessage('Word   is   not   responding!');     
      end     
      else     
          ShowMessage('Word   is   not   open!');     
  end;