Chip 2001 September/Chip_2001-09_cd1.bin/zkuste/delphi/kompon/d23456/PHANTOM.ZIP/Deutsch/Phantom.pas

Pascal/Delphi Source File | 2001-06-20 | 17KB | 583 lines

{

 TPhantom Version 7.0

  erstellt von Roland Gruber  ([e-mail])
                              (http://www.rolandgruber.de)

  Diese Komponente darf in kommerziellen Anwendungen sowie
  zum privaten Gebrauch verwendet werden, solange der Name
  des Programmierers genannt wird (z.B. in einer Info-Box).

  Der Gebrauch der Komponente erfolgt auf eigene Gefahr
  und fⁿr etweige SchΣden wird keine Haftung ⁿbernommen.
  (Auch wenn die Wahrscheinlichkeit dafⁿr eher gering ist.)

  Wenn Sie diese Komponente verbessern oder Anregungen
  haben wⁿrde ich mich ⁿber eine e-mail freuen.
  ([e-mail])

  ACHTUNG!!! Das Verstecken vor dem Taskmanager wird unter Windows NT
  nicht unterstⁿtzt und von der Komponente ignoriert.

  ErklΣrung der Funktionen:

  Sichtbar: legt fest ob das Anwendungsformular sichtbar ist
            (sollte erst zur Laufzeit gesetzt werden: z.B Form.OnActivate)
  Serviceprocess: versteckt das Programm vor dem Taskmanager(Strg+Alt+Entf)
  Icondatei: Name der .ico-Datei die das Symbol fⁿr Taskleiste
             enthΣlt.
  Iconsichtbarkeit: legt fest, ob das Icon in der Taskleiste
                    sichtbar ist.
  Popuprechts: Name des Popupmenⁿs, das erscheint, wenn der
               Benutzer mit der rechten Maustaste auf das
               Taskleistenicon klickt
  Popuplinks:  Dasselbe wie oben mit Klick auf die linke Taste
  Linksklick:  Ereignis,das ausgel÷st wird, wenn der Benutzer
               mit der linken Maustaste auf das Icon klickt
  Rechtsklick: analog zu oben mit der rechten Taste
  Doppelklick: analog zu oben mit einem Doppelklick
  Blinken: LΣ▀t die SchaltflΣche in der Taskbar einmal blinken
           (!!!nach setzen auf true, wechselt es sofort zurⁿck zu false (vorher blinkt es einmal) !!!)
  Blinkdauer: Legt fest, wie lange(ms) das Blinken anhΣlt
  Prioritaet: PrioritΣt der Anwendung
  MausPosX: Position des Mauscursors auf der x-Achse
  MausPosY: Position des Mauscursors auf der y-Achse
  MausRechtsKlick: simulierter Klick der rechten Maustaste
  MausLinksKlick: simulierter Klick der linken Maustaste
  MausMittelKlick: simulierter Klick der mittleren Maustaste
  Sendstring: simuliert die Eingabe eines Strings ⁿber die Tastatur
              ( unterstⁿtzte Zeichen: ABCDEFGHIJKLMNOPQRSTUVWXYZ
                                      abcdefghijklmnopqrstuvwxyz
                                      1234567890!"º$%&/()=
                                      ,.-;:_ +* )
  Eingabesperre: hiermit kann man Maus und Tastatur sperren: bei esNormal kann der Benutzer noch
                 durch Strg+Alt+Entf die Sperre aufheben, bei esHart nicht mehr
  }
 unit Phantom;

interface

uses
  Windows, wintypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  menus, shellapi, extctrls;

  const
  TASKBAREVENT: PChar = 'NewTNIMessage_20';

type

  TPrioritaet = (Idle, Normal, Hoch, Realtime);
  TSperre = (esHart, esNormal, esKeine);
  TPhantom = class(TComponent)
  private
    fIconDatei: Ticon;
    ftip:string  ;
    fSichtbar: Boolean ;
    fServiceprocess: Boolean ;
    fLinksKlick: TNotifyEvent;
    fRechtsKlick: TNotifyEvent;
    fDoppelKlick: TNotifyEvent;
    fIconSichtbarkeit: boolean;
    fPopupRechts: TPopupMenu;
    fPopupLinks: TPopupMenu;
    fblinken:boolean;
    fblinkdauer:integer;
    fprioritaet: TPrioritaet;
    fcursor: TPoint;
    kerneldll: THandle;
    userdll: THandle;
    fkeycode: string;
    feingabesperre:TSperre;
    { Private-Deklarationen }
    procedure PWsichtbarkeit(value:boolean);
    procedure PWserviceprocess(value:boolean);
    procedure sichtbarmachen;
    procedure unsichtbarmachen;
    procedure WPopRechts;
    procedure WPopLinks;
    procedure CreateIcon;
    procedure ChangeIcon;
    procedure DeleteIcon;
    procedure settip(value:string);
    procedure Wicondatei(value:Ticon);
    procedure WIconSichtbarkeit(value:boolean);
    procedure blink(value:boolean);
    procedure prioritaetsetzen(value:TPrioritaet);
    function  getposx:integer;
    function  getposy:integer;
    procedure setposx(value:integer);
    procedure setposy(value:integer);
    procedure setsendstring(value:string);
    procedure SetSperre(value:TSperre);
  protected
    { Protected-Deklarationen }
    procedure serviceprocessEin;
    procedure serviceprocessAus;
    procedure WRechtsklick; virtual;
    procedure WLinksklick; virtual;
    procedure WDoppelklick; virtual;
    procedure WndProc(var Msg: TMessage);
    procedure Notification(Component: TComponent; Operation: TOperation); override;
  public
    { Public-Deklarationen }
      procedure loaded;override;
      destructor Destroy; override;
      constructor Create(AOwner: TComponent); override;
   published
    { Published-Deklarationen }
    procedure MausRechtsKlick;
    procedure MausLinksKlick;
    procedure MausMittelKlick;
    property Sichtbar: Boolean read fsichtbar write PWsichtbarkeit;
    property Serviceprocess: Boolean read fserviceprocess write PWserviceprocess;
    property IconDatei: Ticon read fIconDatei write Wicondatei;
    property LinksKlick: TNotifyEvent read fLinksKlick write flinksklick;
    property RechtsKlick: TNotifyEvent read fRechtsKlick write fRechtsklick;
    property DoppelKlick: TNotifyEvent read fDoppelKlick write fDoppelklick;
    property IconSichtbarkeit: boolean read fIconSichtbarkeit write WIconSichtbarkeit;
    property PopupRechts: TPopupMenu read fPopupRechts write fPopuprechts;
    property PopupLinks: TPopupMenu read fPopupLinks write fPopuplinks;
    property Tip: string read FTip write SetTip;
    property Blinken: boolean read fblinken write blink;
    property Blinkdauer: integer read fblinkdauer write fblinkdauer;
    property Prioritaet: TPrioritaet  read fprioritaet write prioritaetsetzen;
    property MausPosX: integer read getposx write setposx;
    property MausPosY: integer read getposy write setposy;
    property SendString: string read fkeycode write setsendstring;
    property Eingabesperre: TSperre read feingabesperre write SetSperre;
  end;

procedure Register;

implementation

var ficonmessage: UINT;
    FWnd: HWnd;

constructor tphantom.Create(AOwner: TComponent) ;
begin
inherited Create(AOwner);
ficonmessage := RegisterWindowMessage(TASKBAREVENT);
FWnd := AllocateHWnd(WndProc);
FIcondatei := TIcon.Create;
iconsichtbarkeit:=false ;
sichtbar:=true;
serviceprocess:=false;
fblinken:=false;
blinkdauer:=300;
prioritaet:=normal;
kerneldll:=LoadLibrary('kernel32.dll');
userdll:=Loadlibrary('user32.dll');
eingabesperre:=esKeine;
end;

destructor TPhantom.Destroy;
begin
  if Ficonsichtbarkeit then deleteIcon;
  FIcondatei.Free;
  DeallocateHWnd(FWnd);
  FreeLibrary(kerneldll);
  Freelibrary(userdll);
  inherited destroy;
end;

procedure TPhantom.WndProc(var Msg: TMessage);
begin
  with Msg do begin
    if Msg = ficonmessage then
      case LParamLo of
        WM_LBUTTONDOWN:   WLinksKlick;
        WM_RBUTTONDOWN:   WRechtsKlick;
        WM_LBUTTONDBLCLK: WDoppelKlick;
      end
    else
      Result := DefWindowProc(FWnd, Msg, wParam, lParam);
  end;
end;

procedure TPhantom.Notification(Component: TComponent; Operation: TOperation);
begin
  inherited Notification(Component, Operation);
  if Operation = opRemove then begin
    if Component = FPopuprechts then FPopuprechts := nil;
    if Component = FPopuplinks then FPopuplinks := nil;
  end;
end;

procedure TPhantom.PWsichtbarkeit(value:boolean);
begin
fsichtbar:=value;
if (csDesigning in ComponentState) then exit;
if sichtbar=true then sichtbarmachen;
if sichtbar=false then unsichtbarmachen;
end;

procedure TPhantom.PWserviceprocess(value:boolean);
begin
fserviceprocess:=value;
if serviceprocess then serviceprocessEin;
if not serviceprocess then serviceprocessAus;
end;

procedure TPhantom.serviceprocessEin;
type Tregisterservice = function(dwProcessId,dwType:dword): Integer;stdcall;
var registerserviceprocess:Tregisterservice;
begin
  if (csDesigning in ComponentState) then exit;
  @registerserviceprocess:=GetProcAddress(kerneldll, 'RegisterServiceProcess');
  if @registerserviceprocess=nil then exit;
  RegisterServiceProcess(GetCurrentProcessID,1);
end;

procedure TPhantom.serviceprocessAus;
type Tregisterservice = function(dwProcessId,dwType:dword): Integer;stdcall;
var registerserviceprocess:Tregisterservice;
begin
  if (csDesigning in ComponentState) then exit;
  @registerserviceprocess:=GetProcAddress(kerneldll, 'RegisterServiceProcess');
  if @registerserviceprocess=nil then exit;
  RegisterServiceProcess(GetCurrentProcessID,0);
end;

procedure TPhantom.sichtbarmachen;
begin
if (csDesigning in ComponentState) then exit;
showwindow(FindWindow(nil, @Application.Title[1]),SW_RESTORE)
end;

procedure TPhantom.unsichtbarmachen;
var handle:HWND;
begin
if (csDesigning in ComponentState) then exit;
handle:=FindWindow(nil, @Application.Title[1]);
showwindow(handle,SW_MINIMIZE);
showwindow(handle,SW_HIDE) ;
end;

procedure TPhantom.WRechtsklick;
begin
if Assigned(FPopuprechts) then WPoprechts
  else if Assigned(FRechtsKlick) then
    FRechtsKlick(Self);
end;

procedure TPhantom.WLinksklick;
begin
if Assigned(FPopuplinks) then WPoplinks
  else if Assigned(FLinksKlick) then
    FLinksKlick(Self);
end;

procedure TPhantom.WDoppelklick;
begin
if Assigned(Fdoppelklick)then FDoppelKlick(Self);
end;

procedure TPhantom.WPopRechts;
var punkt:Tpoint;
begin
GetCursorPos(Punkt);
SetForeGroundWindow(FWnd);
FPopuprechts.Popup(Punkt.X, Punkt.Y);
end;

procedure TPhantom.WPopLinks;
var punkt:Tpoint;
begin
GetCursorPos(Punkt);
SetForeGroundWindow(FWnd);
FPopuplinks.Popup(Punkt.X, Punkt.Y);
end;

procedure TPhantom.CreateIcon;
var icon: TNOTIFYICONDATA;
begin
with icon do begin
    cbSize := SizeOf(TNOTIFYICONDATA);
    Wnd := FWnd;
    uID := 1;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    uCallbackMessage :=ficonMessage;
    hIcon := FIcondatei.Handle;
    StrCopy(szTip, PChar(FTip));
    Shell_NotifyIcon(NIM_ADD, @icon);
  end;
  ficonsichtbarkeit := true;
end;

procedure TPhantom.ChangeIcon;
var icon: TNOTIFYICONDATA;
begin
with icon do begin
    cbSize := SizeOf(TNOTIFYICONDATA);
    Wnd := FWnd;
    uID := 1;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    uCallbackMessage := ficonMessage;
    hIcon := FIcondatei.Handle;
    StrCopy(szTip, PChar(FTip));
    Shell_NotifyIcon(NIM_MODIFY, @icon);
  end;
ficonsichtbarkeit:=true;
end;

procedure TPhantom.DeleteIcon;
var icon: TNOTIFYICONDATA;
begin
with icon do begin
    cbSize := SizeOf(TNOTIFYICONDATA);
    Wnd := FWnd;
    uID := 1;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    uCallbackMessage := ficonmessage;
    hIcon := FIcondatei.Handle;
    StrCopy(szTip, PChar(FTip));
    Shell_NotifyIcon(NIM_DELETE, @icon);
  end;
  ficonsichtbarkeit := false;
end;

procedure TPhantom.settip(value:string);
begin
if FTip <> value then begin
    FTip := value;
    changeicon;
  end;
end;

procedure TPhantom.Wicondatei(value:Ticon);
begin
if ficondatei<>value then begin
      ficondatei.assign(value);
      if (csDesigning in ComponentState) then exit;
      if ficonsichtbarkeit then changeicon else createicon;
      if ficondatei.empty then deleteicon;
  end;
end;

procedure TPhantom.WIconSichtbarkeit(value:boolean);
begin
ficonsichtbarkeit:=value;
if not (csDesigning in ComponentState) then begin
   if ficonsichtbarkeit then createicon;
   if not ficonsichtbarkeit then deleteicon;
   end;
end;

procedure TPhantom.Loaded;
begin
  inherited Loaded;
  if Ficonsichtbarkeit and not FIcondatei.Empty then begin
    createIcon;
  end;
end;

procedure TPhantom.blink(value:boolean);
begin
fblinken:=value;
if fblinken=false then exit;
flashwindow(application.handle,true);
sleep(fblinkdauer);
flashwindow(application.handle,true);
fblinken:=false;
end;

procedure TPhantom.prioritaetsetzen(value:TPrioritaet);
begin
fprioritaet:=value;
if (csdesigning in componentstate) then exit;
case value of Idle : setpriorityclass(GetCurrentProcess(), IDLE_PRIORITY_CLASS);
              Normal : setpriorityclass(GetCurrentProcess(), NORMAL_PRIORITY_CLASS);
              Hoch : setpriorityclass(GetCurrentProcess(), HIGH_PRIORITY_CLASS);
              Realtime : setpriorityclass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS);
   end;
end;

procedure TPhantom.MausRechtsKlick;
begin
mouse_event(MOUSEEVENTF_RIGHTDOWN,0,0,0,0);
mouse_event(MOUSEEVENTF_RIGHTUP,0,0,0,0);
end;

procedure TPhantom.MausLinksKlick;
begin
mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);
mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);
end;

procedure TPhantom.MausMittelKlick;
begin
mouse_event(MOUSEEVENTF_MIDDLEDOWN,0,0,0,0);
mouse_event(MOUSEEVENTF_MIDDLEUP,0,0,0,0);
end;

procedure TPhantom.setposx(value:integer);
begin
getcursorpos(fcursor);
fcursor.x:=value;
setcursorpos(fcursor.x, fcursor.y);
end;

procedure TPhantom.setposy(value:integer);
begin
getcursorpos(fcursor);
fcursor.y:=value;
setcursorpos(fcursor.x, fcursor.y);
end;

function TPhantom.getposx:integer;
begin
getcursorpos(fcursor);
result:=fcursor.x;
end;

function TPhantom.getposy:integer;
begin
getcursorpos(fcursor);
result:=fcursor.y;
end;

procedure TPhantom.setsendstring(value:string);
var c:byte;
label fertig;
begin
fkeycode:=value;
if length(value)=0 then exit;
while length(value)<>0 do begin
c:=byte(value[1]);
if c>=33 then begin
  if c<=41 then begin
  c:=(c+16);
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
  end;
 end;
if c>=48 then begin
  if c<=57 then begin
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
  end;
 end;
if c>=65 then begin
  if c<=90 then begin
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
  end;
 end;
if c>=97 then begin
  if c<=122 then begin
  c:=(c-32);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
 end;
end;
if c=58 then begin
  c:=190;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=59 then begin
  c:=188;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=95 then begin
  c:=189;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=167 then begin
  c:=51;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=61 then begin
  c:=48;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=42 then begin
  c:=187;
  keybd_event(VK_SHIFT, 0, 0,0);
  keybd_event(c, 0, 0,0);
  keybd_event(c, 0, KEYEVENTF_KEYUP,0);
  keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP,0);
  goto fertig;
end;
if c=43 then c:=187;
if c=44 then c:=188;
if c=46 then c:=190;
if c=45 then c:=189;
 keybd_event(c, 0, 0,0);
 keybd_event(c, 0, KEYEVENTF_KEYUP,0);
fertig:
delete(value,1,1);
application.ProcessMessages;
end;
end;

procedure TPhantom.SetSperre(value:TSperre);
type Tblockinput = function(value:boolean): Dword;stdcall;
var blockinput:Tblockinput;
    j:integer;
begin
  if (csDesigning in ComponentState) then begin
  feingabesperre:=value;
  exit;
  end;
  @blockinput:=GetProcAddress(userdll, 'BlockInput');
  if @blockinput=nil then begin
  feingabesperre:=value;
  exit;
  end;
  if value=esKeine then begin
   blockinput(false);
   if feingabesperre=esHart then SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@j,0);
  end
  else if value=esNormal then begin
   if feingabesperre=esHart then SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@j,0)
   else blockinput(true);
  end
  else if value=esHart then begin
   blockinput(true);
   SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@j,0);
  end;
feingabesperre:=value;
end;

procedure Register;
begin
  RegisterComponents('Roland', [TPhantom]);
end;

end.