unit1.pas

以前用delphi+kol写的监视工具

{ KOL MCK } // Do not remove this line!
{$DEFINE KOL_MCK}
{ KOL MCK }// Do not remove this line!
{$DEFINE KOL_MCK}
unit Unit1;
{parameter :
   -srv:value
         value: host name or ip address.
   -port:value
         value: port value
   -lport:value
         value: listen port value
}
interface

{$IFDEF KOL_MCK}
uses Windows, Messages, ShellAPI, KOL, kolTCPSocket {$IFNDEF KOL_MCK}, mirror, Classes,
  mckObjs, mckTCPSocket, mckCtrls, Controls {$ENDIF};
{$ELSE}
{$I uses.inc}
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
mirror;
{$ENDIF}

type
{$IFDEF KOL_MCK}
{$I MCKfakeClasses.inc}
  PClass_wpolicy = ^TClass_wpolicy;
  TClass_wpolicy = object(TObj)
    Form: PControl;
  {$ELSE not_KOL_MCK}
  TClass_wpolicy = class(TForm)
  {$ENDIF KOL_MCK}
    KOLProject1: TKOLProject;
    KOLForm1: TKOLForm;
    PopupMenu1: TKOLPopupMenu;
    WatchThread: TKOLThread;
    Memo1: TKOLMemo;
    Button1: TKOLButton;
    Button2: TKOLButton;
    Client: TKOLTCPClient;
    srv: TKOLTCPServer;
    Timer1: TKOLTimer;
    procedure PopupMenu1N1Menu(Sender: PMenu; Item: Integer);
    procedure PopupMenu1N2Menu(Sender: PMenu; Item: Integer);
    procedure TrayIcon1Mouse(Sender: TObject; Message: Word);
    procedure PopupMenu1N3Menu(Sender: PMenu; Item: Integer);
    procedure KOLForm1Close(Sender: PObj; var Accept: Boolean);
    procedure KOLForm1FormCreate(Sender: PObj);
    function WatchThreadExecute(Sender: PThread): Integer;
    procedure PopupMenu1N4Menu(Sender: PMenu; Item: Integer);
    procedure Button1Click(Sender: PObj);
    procedure srvClientStreamReceive(Sender: PTCPClient);
    procedure srvClientReceive(Sender: PTCPClient;
      var Buf: array of Byte; const Count: Integer);
    procedure srvClientStreamSend(Sender: PTCPClient);
    procedure ClientDisconnect(Sender: PTCPClient);
    procedure ClientConnect(Sender: PTCPClient);
    procedure ClientError(Sender: PObj; const Error: Integer);
    procedure Button2Click(Sender: PObj);
    procedure ClientReceive(Sender: PTCPClient; var Buf: array of Byte;
      const Count: Integer);
    procedure ClientStreamReceive(Sender: PTCPClient);
    procedure Timer1Timer(Sender: PObj);
    procedure KOLForm1QueryEndSession(Sender: PObj; var Accept: Boolean);
    procedure srvError(Sender: PObj; const Error: Integer);
  private
   TrayIcon1: TKOLTrayIcon;
   G_Handle:Thandle;
    { Private declarations }
  public
    procedure createTrayIcon;
    procedure downloadPolicy;
    procedure AddLog(Log: string);
    { Public declarations }
  end;


var
  Class_wpolicy{$IFDEF KOL_MCK}: PClass_wpolicy{$ELSE}: TClass_wpolicy{$ENDIF};

{$IFDEF KOL_MCK}
procedure NewClass_wpolicy( var Result: PClass_wpolicy; AParent: PControl );
{$ENDIF}

implementation
uses TlHelp32, uglobal;

{$IFDEF KOL_MCK}
{$I Unit1_1.inc}
{$ENDIF}
{$IFNDEF KOL_MCK} {$R *.DFM} {$ENDIF}

var disList: pDisList;
  downloadstream: pStream;

procedure TClass_wpolicy.PopupMenu1N1Menu(Sender: PMenu; Item: Integer);
begin
  if Self.Form.Visible then
    Self.Form.Hide
  else
    Self.Form.Show;
end;

procedure TClass_wpolicy.PopupMenu1N2Menu(Sender: PMenu; Item: Integer);
begin
  self.Form.Close;
end;

procedure getProcesses(var ExeInfo: PStrList);
var
  pe: PROCESSENTRY32;
//  me: MODULEENTRY32;
  hp {, hm}: Thandle;
  b {, b1}: boolean;
begin
  hp := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  pe.dwSize := SizeOf(pe);
  b := Process32First(hp, pe);
  ExeInfo.Clear;
  while b do
  begin
    {hm:=CreateToolHelp32SnapShot(TH32CS_SNAPModule,pe.th32ProcessID);
    me.dwSize:=sizeof(ModuleEntry32);
    if Module32First(hm,me) then
    begin
      b1:=Module32First(hm,me);
      while  b1 do begin
        if ExtractFileName(me.szExePath)=pe.szExeFile then
          ExeInfo.Add(int2str(pe.th32ProcessID) +'='+string(me.szExePath));
        b1:=Module32Next(hm,me);
      end;
    end;
    CloseHandle(hm);}
    ExeInfo.Add(int2str(pe.th32ProcessID) + '=' + string(pe.szExeFile));
    b := Process32Next(hp, pe);
  end;
  CloseHandle(hp);
end;

procedure TClass_wpolicy.TrayIcon1Mouse(Sender: TObject; Message: Word);
var winpos: Tpoint;
begin
  GetCursorPos(winpos);
  case Message of
    516: begin
        PopupMenu1.Popup(winpos.X, winpos.Y);
      end;
  end;
end;

procedure TClass_wpolicy.PopupMenu1N3Menu(Sender: PMenu; Item: Integer);
var Exe: PStrList;
begin
  Exe := NewStrList;
  try
    getProcesses(exe);
    Memo1.Text := exe.Text;
    //self.Form.Caption := int2str(GetCurrentProcessID);
  finally
    exe.Free;
  end;
end;

procedure TClass_wpolicy.KOLForm1Close(Sender: PObj; var Accept: Boolean);
begin
  if @m_RegisterServiceProcess <>nil then
    m_RegisterServiceProcess(GetCurrentProcessID, 0);
  Accept :=form.tag=1;
  if not Accept then exit;
  if disList<>nil then
  begin
    disList.Free;
    disList:=nil;
  end;
  if G_Handle <>0 then
     GlobalDeleteAtom(G_Handle );
end;

procedure TClass_wpolicy.CreateTrayicon;
begin
  TrayIcon1 := NewTrayIcon(Applet, 0);
{$R classPolicySrv_TrayIcon1.RES}
  TrayIcon1.Icon := LoadIcon(hInstance, 'ZCLASSPOLICYSRV_TRAYICON1');
  Form.Add2AutoFree(TrayIcon1);
  TrayIcon1.OnMouse := TrayIcon1Mouse;
  TrayIcon1.Active := true;//not C_SYSParm.Hide;
end;

procedure TClass_wpolicy.KOLForm1FormCreate(Sender: PObj);
  procedure showsplash;
  begin
    Addlog('/' + RepeatStr('-', 80) + '\');
    AddLog(RepeatStr(' ', 8) + self.Form.Caption);
    Addlog(RepeatStr(' ', 10) + RepeatStr('=', 30));
    Addlog(RepeatStr(' ', 10) + 'Bug report: [e-mail]');
    //Addlog(RepeatStr(' ', 10) + 'Home Page : http://');
    Addlog('\' + RepeatStr('-', 80) + '/');
  end;
  procedure ProcClient;
  begin
    Client.Host := C_SYSParm.srv;
    Client.Port := C_SYSParm.Port;
    try
      Client.Connect;
    except
    end;
  end;
begin
  self.Form.Caption:=G_Title; 
  if (GlobalFindAtom(pchar(form.ClassName))=0) then
    if not C_SYSParm.Exit then G_Handle := GlobalAddAtom(pchar(form.ClassName))
  else begin
    form.Hide ;
    form.Tag :=1;
    if not C_SYSParm.Exit then
     G_Handle := 0
    else begin
     G_Handle:=GlobalFindAtom (pchar(form.ClassName));
    end;
    form.close;
    exit;
  end;
  if C_SYSParm.Exit then exit;
  if @m_RegisterServiceProcess <>nil then
    m_RegisterServiceProcess(GetCurrentProcessID, 1);
  Memo1.Text := '';
  if C_SYSParm.Hide then begin
    form.Width :=1;
    form.Height :=1;
    form.Left :=-1;
    form.Top :=-1;
  end
  else
    createTrayIcon;
  showsplash;
  disList := newDisList;
  try
    if C_SYSParm.list <> '' then
      listLoadFromFile(C_SYSParm.list, disList);
    if C_SYSParm.lPort <> 0 then begin
      srv.Port := C_SYSParm.lPort;
      try
        srv.Listen;
      except
      end;
    end;
    if (C_SYSParm.srv <> '') and (C_SYSParm.Port <> 0) then begin
      ProcClient;
    end;
  finally
    WatchThread.Resume;
  end;
end;

function TClass_wpolicy.WatchThreadExecute(Sender: PThread): Integer;
var p: pStrList;
  k,j, i: integer;
  Item: pDisableInfo;
  EXE_name, _Name: string;
begin
  p := NewStrList;
  SLEEp(700);
  Self.Form.Hide;
  k:=0;
  try
    while not Sender.Terminated do begin
      Sleep(200);
      inc(k);
      if k>10000 then
        k:=0;
      if k mod 150=0 then begin
        if (C_SYSParm.Port  <>0) and not Client.Connected  then begin
           Client.Connect ;
        end;
      end;

      try
        getProcesses(p);
        for i := 0 to p.Count - 1 do begin
          _Name := p.Items[i];
          _Name := Copy(_Name, 1, pos('=', _Name) - 1);
          exe_name := uppercase(ExtractFileName(p.Values[_Name]));
          Applet.ProcessMessages;
          for j := 0 to disList.Count - 1 do begin
            Item := disList.Items[j];
            if item.ExeName = exe_name then begin
              TerminatePID(Str2Int(_Name));
            end;
          end;
        end;
      except
      end;
    end;
  finally
    p.Free;
  end;
end;

procedure TClass_wpolicy.PopupMenu1N4Menu(Sender: PMenu; Item: Integer);
var i: integer;
begin
  Addlog('');
  for i := 0 to disList.Count - 1 do begin
    Addlog(pDisableInfo(disList.items[i]).ExeName);
  end;
end;

procedure TClass_wpolicy.Button1Click(Sender: PObj);
begin
  self.Form.Hide;
end;

procedure TClass_wpolicy.AddLog(Log: string);
begin
  memo1.add(log + #13#10);
end;

procedure TClass_wpolicy.srvClientStreamReceive(Sender: PTCPClient);
begin
//
end;

procedure TClass_wpolicy.srvClientReceive(Sender: PTCPClient;
  var Buf: array of Byte; const Count: Integer);
var s: string;
  value, cmd: string;
begin
{
 //list_load#size: load file list
 list_add#value:
 list_del#value;
 procs_get;
 procs_kill;
 scrn_get;
}
  setlength(s, count);
  move(buf, s[1], count);
  s := uppercase(s);
  if pos('#', s) <> 0 then begin
    cmd := copy(s, 1, pos('#', s) - 1);
    value := s; delete(value, 1, pos('#', s));
    if cmd = 'LIST_LOAD' then begin //load
    end;
  end
  else begin
  end;
end;

procedure TClass_wpolicy.srvClientStreamSend(Sender: PTCPClient);
begin
//
end;

procedure TClass_wpolicy.ClientDisconnect(Sender: PTCPClient);
begin
  addlog('Disconnected.');
  Timer1.Enabled := false;
end;

procedure TClass_wpolicy.downloadPolicy;
begin
  sleep(200);
  if Client.Connected then
    Client.SendString('down,policy');
end;

procedure TClass_wpolicy.ClientConnect(Sender: PTCPClient);
var t: TsrvUserInfo;
begin
  t._type := '@@';
  t.userName := _UserName;
  t.host := _ComputerName;
  t.IP := '';
  t.lport := int2str(C_SYSParm.lPort);
  t.stTime := '';
  //Client.SendString('@@'+_UserName +','+_ComputerName );
  Client.Send(t, sizeof(t));
  addlog('Connected.');
  addlog('downloading access policy ...');
  downloadPolicy;
  Timer1.Enabled := true;
end;

procedure TClass_wpolicy.ClientError(Sender: PObj; const Error: Integer);
begin
//
end;

procedure TClass_wpolicy.Button2Click(Sender: PObj);
begin
  self.form.close;  //
end;

procedure TClass_wpolicy.ClientReceive(Sender: PTCPClient;
  var Buf: array of Byte; const Count: Integer);
var l_s: string;
  l_count: integer;
  l_buf: array of byte;
begin
  with sender^ do begin
    setlength(l_s, count);
    move(buf, l_s[1], count);
    if copy(l_s, 1, 6) = 'policy' then begin
      if downloadstream <> nil then downloadstream.free;
      downloadstream := NewMemoryStream;
        //sender.fRecStream.Position :=6;
      Sender.DeleteRecBuffer(6);
      l_count := ReadInteger;
      setlength(l_buf, l_count);
      sender.ReceiveBufWait(l_buf[0], l_count);
      downloadstream.Write(l_buf[0], l_count);
      listLoadFromBuf(downloadstream, disList);
      AddLog('Add policy ' + int2str(disList.Count) + ' items.')
    end;
    if copy(l_s, 1, 6) = 'reload' then begin
      Sender.DeleteRecBuffer(6);
      downloadPolicy;
    end;
  end;
end;

procedure TClass_wpolicy.ClientStreamReceive(Sender: PTCPClient);
var l_f: pStrList;
begin
  if not Sender.StreamReceiving then begin
    l_f := NewStrList;
    try
      l_f.LoadFromStream(downloadstream, false);
      listLoadFromBuf(l_f, disList);
    finally
      l_f.Free;
      downloadstream.Free;
    end;
  end;
end;

procedure TClass_wpolicy.Timer1Timer(Sender: PObj);
begin
  downloadPolicy;
end;


procedure TClass_wpolicy.KOLForm1QueryEndSession(Sender: PObj;
  var Accept: Boolean);
begin
  //ShowMessage ('aa');
  if @m_RegisterServiceProcess <>nil then begin
     m_RegisterServiceProcess(GetCurrentProcessId ,0);
  end;
  form.Tag :=1;
  SendMessage(form.handle,wm_close,0,0);
  Accept:=true;
end;

procedure TClass_wpolicy.srvError(Sender: PObj; const Error: Integer);
begin
  SendMessage(form.handle,wm_queryendsession,0,0);
end;

end.