Monitor Scktsrvr

Monitor Scktsrvr.exe

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, uThreadTimer, TlHelp32, ExtCtrls, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    StatusBar1: TStatusBar;
    btTurn: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Memo1Change(Sender: TObject);
    procedure Memo1DblClick(Sender: TObject);
    procedure btTurnClick(Sender: TObject);
  private
    { Private declarations }
    iCount,jCount: integer;
    ThreadTimer: TThreadTimer;
    Procedure OnTimer(Sender: TObject);
  public
    { Public declarations }
    function GetConnectCount:Integer;
    procedure TerminateProcessEx;
    procedure MonitorProcessEx;
    function IsProcessExist:Boolean;
    procedure CheckAppStatus;
  end;

var
  Form1: TForm1;
  bMonitor: Boolean;

implementation


{$R *.dfm}

function FindProcessID(ExeName: string): Longword;
  function AnsiEndsText(const ASubText, AText: string): Boolean;
  var
    P: PChar;
    L, L2: Integer;
  begin
    P := PChar(AText);
    L := Length(ASubText);
    L2 := Length(AText);
    Inc(P, L2 - L);
    if L > L2 then
      Result := False
    else
      Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P, L,
        PChar(ASubText), L) = 2;
  end;
var
  sphandle, sthandle: DWORD;
  Found: Bool;
  PStruct: TProcessEntry32;
  TStruct: TThreadEntry32;
begin
  Result := 0;
  sphandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  try
    PStruct.dwSize := Sizeof(PStruct);
    TStruct.dwSize := Sizeof(TStruct);
    Found := Process32First(sphandle, PStruct);
    while Found do
    begin
      if AnsiEndsText(ExeName, PStruct.szExefile) then
      begin
        sthandle := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
        try
          Found := Thread32First(sthandle, TStruct);
          while Found do
          begin
            if TStruct.th32OwnerProcessID = PStruct.th32ProcessID then
            begin
              Result := TStruct.th32OwnerProcessID;
              Exit;
            end;
            Found := Thread32Next(sthandle, TStruct);
          end;
        finally
          CloseHandle(sthandle);
        end;
      end;
      Found := Process32Next(sphandle, PStruct);
    end;
  finally
    CloseHandle(sphandle);
  end;
end;

{ TODO : 在本程序中没有用到 }
function KillProcess(ExeFileName: string): Integer;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := 0;
  if ExeFileName = '' then
    exit;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
      if FProcessEntry32.th32ProcessID <> GetCurrentProcessID then
        Result := Integer(TerminateProcess(
          OpenProcess(PROCESS_TERMINATE,
          BOOL(0),
          FProcessEntry32.th32ProcessID),
          0));
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;

procedure TForm1.TerminateProcessEx;
var
  id: Cardinal;
  wh: HWND;
  ph: THandle;
  ExitCode: DWORD;
begin
  try
    wh := FindWindow('TSocketForm','Borland Socket Server');
    GetWindowThreadProcessId(wh, id);
    ph := OpenProcess(PROCESS_TERMINATE, False, id);
    GetExitCodeProcess(ph, ExitCode);
    TerminateProcess(ph, ExitCode);
    if ph <> 0 then
      CloseHandle(ph);
  except
    on e: Exception do
      Memo1.Lines.Add('ErrMsg ' + e.Message)
  end;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
  ShowWindow(Application.Handle, SW_HIDE);
  SetWindowLong(Application.Handle, GWL_EXSTYLE, getWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
  ShowWindow(Application.Handle, SW_SHOW);
  iCount := 0;
  jCount := 0;
  Memo1.Clear;
  Memo1.Lines.Add('Program Upgrade date: 2009-12-27');
end;

procedure TForm1.OnTimer(Sender: TObject);
var
  i,iRet: integer;
begin
  StatusBar1.Panels.Items[0].Text := 'Time: ' + FormatDateTime('YYYY-MM-DD HH:NN:SS',now);
  i := FindProcessID('scktsrvr.exe');
  if i = 0 then
  begin
    Memo1.Lines.Add('Close at ' + FormatDateTime('YYYY-MM-DD HH:NN:SS',now));
    winexec('scktsrvr.exe Login',SW_NORMAL);
  end;
  iRet := GetConnectCount;
  if iRet > 3 then
  begin
    Inc(iCount);
    if iCount > 90 then
    begin
      TerminateProcessEx;
      Memo1.Lines.Add(IntToStr(iRet) + ' Force Close at '
              + FormatDateTime('YYYY-MM-DD HH:NN:SS',now));
      Sleep(1000);
    end;
  end
  else
    iCount := 0;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  //ThreadTimer.Terminate;
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
  if Memo1.Lines.Count > 100 then
     Memo1.Lines.Delete(0);
end;

procedure TForm1.Memo1DblClick(Sender: TObject);
var
  iRet: Integer;
begin
  Memo1.Clear;
  iRet := GetConnectCount;
  Memo1.Lines.Add(IntToStr(iRet));
end;

function TForm1.GetConnectCount: Integer;
var
  hMain,hPage,hTab,hStatusBar: THandle;
  s:string;
  buf: array [0..255] of char;
begin
  Result := 0;
  FillChar(buf,256,#0);
  hMain := FindWindow('TSocketForm','Borland Socket Server');
  if hMain <> 0 then
    hPage := FindWindowEx(hMain,0,'TPageControl',0);
  if hPage <> 0 then
    hTab  := FindWindowEx(hPage,0,'TTabSheet',0);
  if hTab <> 0 then
    hStatusBar := FindWindowEx(hTab,0,'TStatusBar',0);
  if hStatusBar <> 0 then
    SendMessage(hStatusBar,WM_GETTEXT,255,Integer(@buf[0]));
  S := buf;
  if s <> '' then
    Result := StrToInt(copy(S,1,1));
end;

procedure TForm1.CheckAppStatus;
var
  i,iRet: integer;
begin
  StatusBar1.Panels.Items[0].Text := 'Time: ' + FormatDateTime('YYYY-MM-DD HH:NN:SS',now);
  i := FindProcessID('scktsrvr.exe');
  if i = 0 then
    Memo1.Lines.Add('Close at ' + FormatDateTime('YYYY-MM-DD HH:NN:SS',now));
  //
  iRet := GetConnectCount;
  if iRet > 3 then
  begin
    Inc(iCount);
    if iCount > 90 then
    begin
      TerminateProcessEx;
      Memo1.Lines.Add(IntToStr(iRet) + ' Force Close1 at '
              + FormatDateTime('YYYY-MM-DD HH:NN:SS',now));
    end;
  end
  else
    iCount := 0;
  //
  if iRet > 8 then
  begin  //如果超过10个连接并且持续3秒,结束程序
    Inc(jCount);
    if jCount > 1 then
    begin
      TerminateProcessEx;
      Memo1.Lines.Add(IntToStr(iRet) + ' Force Close2 at '
              + FormatDateTime('YYYY-MM-DD HH:NN:SS',now));
    end;
  end
  else
    jCount := 0;
end;

function TForm1.IsProcessExist: Boolean;
begin
  Result := FindProcessID('scktsrvr.exe') <> 0;
end;

procedure TForm1.MonitorProcessEx;
var
  StartupInfo:TStartupInfo;
  ProcessInfo:TProcessInformation;
  I_AppRunning: Cardinal;
  FullFileName: String;
begin
  if not FileExists('scktsrvr.exe') then
  begin
    ShowMessage('File:scktsrvr.exe not exist');
    Exit;
  end;
  //FullFileName := StrCat(PChar(IncludeTrailingPathDelimiter(GetCurrentDir)), 'scktsrvr.exe');
  FillChar(StartupInfo,Sizeof(StartupInfo),0);
  StartupInfo.cb := Sizeof(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := SW_SHOWNORMAL;
  {$define 0}
  {$ifdef 1}
  CreateProcess(nil,
                'scktsrvr.exe Login',
                nil,
                nil,
                false,
                0,//CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
                nil,
                nil,
                StartupInfo,
                ProcessInfo);
  {$else}
  CreateProcess(nil,//PChar('scktsrvr.exe'),//nil,
                PChar('scktsrvr.exe Login'),
                nil,
                nil,
                false,
                0,//CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
                nil,
                nil,
                StartupInfo,
                ProcessInfo);
  {$endif}
  repeat
    I_AppRunning := WaitForSingleObject(ProcessInfo.hProcess,1000);
    CheckAppStatus;
    if not bMonitor then Break;
    Application.ProcessMessages;
  until (I_AppRunning <> WAIT_TIMEOUT);
  if not bMonitor then Exit;  
  if ProcessInfo.hProcess <> 0 then CloseHandle(ProcessInfo.hProcess);
  if ProcessInfo.hThread  <> 0 then CloseHandle(ProcessInfo.hThread);
  MonitorProcessEx;
end;

procedure TForm1.btTurnClick(Sender: TObject);
begin
  bMonitor := not bMonitor;
  if bMonitor then
  begin
    btTurn.Caption := 'Stop';
    if IsProcessExist then TerminateProcessEx;
    Sleep(20);
    MonitorProcessEx;
  end
  else
  begin
    btTurn.Caption := 'Run';
  end;
end;

end.