Assa's Service Unit unter Windows 7 macht Probleme

[TheGame1492]

Huhu,

also ich benutze "Assa's Service Unit" schon ein weilchen...

Delphi-Quellcode:

(****************************************************************
****************************************************************
***                                                          ***
***        Copyright (c) 2001 by -=Assarbad [GoP]=-          ***
***       ____________                 ___________           ***
***      /\   ________\               /\   _____  \          ***
***     /  \  \       /    __________/  \  \    \  \         ***
***     \   \  \   __/___ /\   _____  \  \  \____\  \        ***
***      \   \  \ /\___  \  \  \    \  \  \   _______\       ***
***       \   \  \ /   \  \  \  \    \  \  \  \      /       ***
***        \   \  \_____\  \  \  \____\  \  \  \____/        ***
***         \   \___________\  \__________\  \__\            ***
***          \  /           /  /          /  /  /            ***
***           \/___________/ \/__________/ \/__/             ***
***                                                          ***
***  May the source be with you, stranger ... :-)            ***
***                                                          ***
***  Greets from -=Assarbad [GoP]=- ...                      ***
***  Special greets go 2 Nico, Casper, SA, Pizza, Navarion...***
***[for questions/proposals drop a mail to [email][e-mail][/email]]***
*****************************************ASCII by Assa [GoP]****
****************************************************************)

(****************************************************************
***  modified for FPC / Lazarus                              ***
***  by gbl (Günter Wukoutz) in 08-2005                      ***
****************************************************************)

//include file for creating a service!

{$APPTYPE CONSOLE}
CONST
  cmd_install='Attempting to install "'+servicename+'" as a';
  cmd_installed='"%s" was successfully %sinstalled';
  press_anykey=#13#10#13#10+'Press any key to continue.';
  cmd_header=servicename+' - (c) 2005 by Guenter Wukoutz'+#13#10#13#10;
  cmd_syntax='Syntax : %s [/command+parameter]'#13#10#13#10+
    'Commands are single characters:'#13#10+
    'I'#9'Installs "'+servicename+'" as a service'#13#10+
    #9'Parameter:'#13#10+
    #9#9'A = Auto start, M = Manual start'#13#10+
    'U'#9'Uninstalls "'+servicename+'"'#13#10+
    press_anykey;

VAR
//  dispatchtable:ARRAY[0..1] OF tservicetableentry;
  sshstatushandle: service_status_handle;
  ssstatus: service_status;
  stopped: boolean;
  paused: boolean;
  param: STRING;
  currtextattr: word;
  modname: ARRAY[0..MAX_PATH-1] OF char;
  hSCM,
    hService: SC_HANDLE;
  startupmode: integer;

FUNCTION GetErrorMessage(code: Integer): STRING;
VAR
  hErrLib: DWORD;
  msg: PChar;
  flags: integer;

  FUNCTION MAKELANGID(p, s:word):Integer;
  BEGIN
    result:=(s SHL 10) OR p
  END;

BEGIN
  hErrLib:=LoadLibraryEx('NETMSG.DLL', 0, LOAD_LIBRARY_AS_DATAFILE);
  TRY
    flags:=FORMAT_MESSAGE_ALLOCATE_BUFFER OR
           FORMAT_MESSAGE_IGNORE_INSERTS OR
           FORMAT_MESSAGE_FROM_SYSTEM;
           
    CASE (hErrLib<>0) OF
      false:flags:=flags OR FORMAT_MESSAGE_FROM_HMODULE;
    END;
   
    IF FormatMessage(flags,
      pointer(hErrLib),
      code,
      integer((SUBLANG_NEUTRAL SHL 10)OR LANG_NEUTRAL),
      pchar(@msg),
      0,
      NIL)<>0
    THEN
      result:=STRING(msg);
     
    LocalFree(Integer(msg));
   
  FINALLY
    IF hErrLib<>0 THEN FreeLibrary(hErrLib)
  END
END;

PROCEDURE FatalError;
BEGIN
//  currtextattr:=textattribute;
//  settextattribute(FOREGROUND_RED OR FOREGROUND_INTENSITY);
  writeln('Error!');
//  settextattribute(currtextattr);
  writeln(Geterrormessage(getlasterror));
  halt;
END;

FUNCTION frmt(mformat:STRING; args:ARRAY OF POINTER): STRING;
VAR
  bla: pchar;
CONST
  Size=1024;
BEGIN
  getmem(bla, size);
  ZeroMemory(bla, size);
//  wvsprintf(bla, pchar(mformat), pchar(@args));
  result:=STRING(bla);
  freemem(bla, size);
END;

PROCEDURE servicehandler(fdwcontrol: DWORD); STDCALL;
BEGIN
  CASE fdwcontrol OF
    SERVICE_CONTROL_STOP:
      BEGIN
        stopped:=true;
        ssstatus.dwcurrentstate:=service_stop_pending;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_PAUSE:
      BEGIN
        paused:=true;
        ssstatus.dwcurrentstate:=service_paused;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_CONTINUE:
      BEGIN
        paused:=false;
        ssstatus.dwcurrentstate:=service_running;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_INTERROGATE:
      setservicestatus(sshstatushandle, ssstatus);
    SERVICE_CONTROL_SHUTDOWN:
      stopped:=true;
  END;
END;

PROCEDURE serviceproc(dwargc: DWORD; lpszargv:pchar); STDCALL;   // var lpsz...
BEGIN
  sshstatushandle:=registerservicectrlhandler(pchar(servicename), @servicehandler);
  IF (sshstatushandle<>0) THEN BEGIN
    zeromemory(@ssstatus, sizeof(ssstatus));
    ssstatus.dwservicetype:=SERVICE_WIN32_OWN_PROCESS;
    ssstatus.dwcurrentstate:=SERVICE_START_PENDING;
    ssstatus.dwcontrolsaccepted:=SERVICE_ACCEPT_STOP OR SERVICE_ACCEPT_PAUSE_CONTINUE;
    ssstatus.dwwaithint:=1000;
    setservicestatus(sshstatushandle, ssstatus);
    stopped:=false;
    paused:=false;
    ssstatus.dwcurrentstate:=SERVICE_RUNNING;
    setservicestatus(sshstatushandle, ssstatus);
    SERVICE_MAIN;
    ssstatus.dwcurrentstate:=SERVICE_STOPPED;
    setservicestatus(sshstatushandle, ssstatus);
  END;

END;

PROCEDURE showsyntax;
BEGIN
  write(cmd_syntax);
//  write(frmt(cmd_syntax, [@modname[0]]));
//  readkey;
END;

PROCEDURE startasservice;
var dispatchtable:ARRAY[0..1] of tservicetableentry;
BEGIN
  dispatchtable[0].lpservicename:=pchar(servicename);
  dispatchtable[0].lpserviceproc:=@serviceproc;
  dispatchtable[1].lpservicename:=NIL;
  dispatchtable[1].lpserviceproc:=NIL;
  StartServiceCtrlDispatcher(@dispatchtable[0]);
END;

PROCEDURE PROG_MAIN;
BEGIN
  CASE paramcount OF
    0:startasservice;
  ELSE
  BEGIN
      GetModuleFileName(hInstance, @modname[0], MAX_PATH);
      Getlasterror;
      param:=paramstr(1);
      CASE param[1]='/' OF
        true:BEGIN
//            currtextattr:=textattribute;
//            settextattribute(FOREGROUND_GREEN OR FOREGROUND_INTENSITY);
            writeln(cmd_header);
//            settextattribute(currtextattr);
            CASE param[2] OF
              'I', 'i':BEGIN
//                  currtextattr:=textattribute;
//                  settextattribute(FOREGROUND_BLUE OR FOREGROUND_INTENSITY);
                  StartupMode:=SERVICE_DEMAND_START;
                  IF length(param)>2 THEN
                    CASE param[3] OF
                      'A', 'a':startupMode:=SERVICE_AUTO_START;
                    END
                    ELSE
                      StartupMode:=SERVICE_DEMAND_START;
                     
                  CASE startupMode OF
                    SERVICE_AUTO_START: writeln(cmd_install+'n autostart service');
                    SERVICE_DEMAND_START: writeln(cmd_install+' manual start service');
                  END;
                 
//                  settextattribute(currtextattr);
                  hSCM:=OpenSCManager(NIL, NIL, SC_MANAGER_ALL_ACCESS);
                  CASE hSCM OF
                    0:FatalError;
                  ELSE
                  BEGIN
                      hService:=CreateService(hSCM,
                        PChar(ServiceName),
                        PChar(DisplayName),
                        SERVICE_START OR SERVICE_QUERY_STATUS OR SERVICE_DELETE,
                        SERVICE_WIN32_OWN_PROCESS,// or SERVICE_INTERACTIVE_PROCESS,
                        StartupMode,
                        SERVICE_ERROR_NORMAL,
                        @modname[0],
                        NIL, NIL, NIL, NIL, NIL);
                      CASE hService OF
                        0:BEGIN
                            CloseServiceHandle(hSCM);
                            FatalError;
                          END;
                      ELSE
                      BEGIN
                          CloseServiceHandle(hSCM);
                          CloseServiceHandle(hService);
                          writeln(frmt(cmd_installed, [pchar(servicename), pchar('')]));
                        END;
                      END;
                    END;
                  END;
                END;
              'U', 'u':BEGIN
//                  currtextattr:=textattribute;
//                  settextattribute(FOREGROUND_BLUE OR FOREGROUND_INTENSITY);
                  writeln('Attempting to uninstall "'+servicename+'"');
//                  settextattribute(currtextattr);
                  hSCM:=OpenSCManager(NIL, NIL, SC_MANAGER_ALL_ACCESS);
                  CASE hSCM OF
                    0:FatalError;
                  ELSE
                  BEGIN
                      hService:=OpenService(hSCM, PChar(Servicename), SERVICE_ALL_ACCESS);
                      CASE hService OF
                        0:BEGIN
                            CloseServiceHandle(hSCM);
                            FatalError;
                          END;
                      ELSE
                      BEGIN
                          startupMode:=integer(DeleteService(hService));
                          CloseServiceHandle(hService);
                          CloseServiceHandle(hSCM);
                          CASE startupMode OF
                            0:FatalError;
                          ELSE
                            writeln(frmt(cmd_installed, [pchar(servicename), pchar('un')]));
                          END;//case
                        END;
                      END;//case
                    END;
                  END;//case
                END;
            ELSE
              showsyntax;
             
            END;//case
          END;
        false: startasservice;
      END;
    END;
  END;
END;

... damit gabs unter Windows XP und 2000 nie Probs.
Aber jetzt unter Windows 7 und Vista, bläst sich jedes Programm das ich mit dieser Unit als Service starte, wie ein Ballon auf im Arbeitsspeicher und führt zu einer permanenten 100% CPU Auslastung.


Woran kann das liegen? :(

EDIT: Es liegt 100% an der Unit mit der Service VCL laufen die Programme ohne probs, vllt weiß jemand rat?!?