delphi 创建windows 服务应用

1.项目文件代码

program SCLQData;

uses
  Forms,
  Windows,
  SysUtils,
  uCiaServiceTools in 'uCiaServiceTools.pas',
  superobject in 'common\superobject.pas',
  uCommonConst in 'common\uCommonConst.pas',
  uCommonFunc in 'common\uCommonFunc.pas',
  Winapi.GDIPAPI in 'common\Winapi.GDIPAPI.pas',
  Winapi.GDIPOBJ in 'common\Winapi.GDIPOBJ.pas',
  Winapi.GDIPUTIL in 'common\Winapi.GDIPUTIL.pas',
  uSimpleThread in 'common\uSimpleThread.pas',
  uThreadTimer in 'common\uThreadTimer.pas',
  USCLQData in 'USCLQData.pas' {frmmain};

{$R *.res}

const
  CSMutexName = 'Global\SCLQData_Mutex';

var
  OneInstanceMutex: THandle;
  SecMem: SECURITY_ATTRIBUTES;
  aSD: SECURITY_DESCRIPTOR;
begin

  ReportMemoryLeaksOnShutdown := DebugHook <> 0;

  InitializeSecurityDescriptor(@aSD, SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@aSD, True, nil, False);
  SecMem.nLength := SizeOf(SECURITY_ATTRIBUTES);
  SecMem.lpSecurityDescriptor := @aSD;
  SecMem.bInheritHandle := False;
  OneInstanceMutex := CreateMutex(@SecMem, False, CSMutexName);

  if (GetLastError = ERROR_ALREADY_EXISTS) then
  begin
    MessageBox(GetActiveWindow, PChar('程序或服务正在运行！'), PChar('提示信息'), MB_OK + MB_ICONINFORMATION);
    CloseHandle(OneInstanceMutex);
    Exit;
  end;

  if CiaStartService('SCLQData') then  // 用管理员运行cmd ,命令 SCLQData.exe /install
  begin
    CiaService.CreateForm(TfrmMain, frmMain);
    CiaService.Run;
    Exit;
  end;




  Forms.Application.Initialize;
  Forms.Application.MainFormOnTaskbar := false;  //已服务的形式运行
  Forms.Application.CreateForm(Tfrmmain, frmmain);
  Application.Run;
end.

2.工具文件代码

unit uCiaServiceTools;

interface

uses
  SysUtils, Classes, Windows, SvcMgr, WinSvc;

type
  TCiaService = class(TService)
    procedure ServiceAfterInstall(Sender: TService);
    procedure ServiceBeforeInstall(Sender: TService);
  protected
    procedure Start(Sender: TService; var Started: boolean);
    procedure Stop(Sender: TService; var Stopped: boolean);
    procedure Execute(Sender: TService);
  public
    function GetServiceController: TServiceController; override;
    constructor CreateNew(AOwner: TComponent; Dummy: integer = 0); override;
    procedure CreateForm(InstanceClass: TComponentClass; var Reference);
    procedure Run;
  end;

function CiaStartService(DisplayName: string): Boolean;
function CiaIsService: boolean;

var
  CiaService        : TCiaService;

implementation

var
  FIsService        : boolean;
  FServiceName      : string;
  FDisplayName      : string;

const
  RegServiceURL = 'SYSTEM\CurrentControlSet\Services\';
  RegDescription = 'Description';
  RegImagePath = 'ImagePath';
  ServiceDescription = '测试服务';

  //------------------------------------------------------------------------------
  //---- TCiaService -------------------------------------------------------------
  //------------------------------------------------------------------------------

procedure ServiceController(CtrlCode: dword); stdcall;
begin
  CiaService.Controller(CtrlCode);
end;

function RegWriteString(const RootKey: HKEY; const SubKey, ValueName, Value: string): Boolean;
{
  写入一个字符串到注册表中
  RootKey：指定主分支
  SubKey：子键的名字
  ValueName：键名，可以为空，为空即表示写入默认值
  Value：数据
}
var
  Key: HKEY;
  R: DWORD;
begin
  Result := (ERROR_SUCCESS = RegCreateKeyEx(RootKey, PChar(SubKey), 0, 'Data',
    REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, Key, @R)) and
    (ERROR_SUCCESS = RegSetValueEx(Key, PChar(ValueName), 0, REG_SZ, PChar(Value), Length(Value) * SizeOf(Char)));
  RegCloseKey(Key);
end;

function RegValueDelete(const RootKey: HKEY; const SubKey, ValueName: string): Boolean;
{
  删除注册表中指定的键值
}
var
  RegKey: HKEY;
begin
  Result := False;
  if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_SET_VALUE, RegKey) = ERROR_SUCCESS then
  begin
    Result := RegDeleteValue(RegKey, PChar(ValueName)) = ERROR_SUCCESS;
    RegCloseKey(RegKey);
  end
end;

//------------------------------------------------------------------------------

function TCiaService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

//------------------------------------------------------------------------------

procedure TCiaService.CreateForm(InstanceClass: TComponentClass; var Reference);
begin
  SvcMgr.Application.CreateForm(InstanceClass, Reference);
end;

//------------------------------------------------------------------------------

procedure TCiaService.Run;
begin
  SvcMgr.Application.Run;
end;

//------------------------------------------------------------------------------

constructor TCiaService.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
  inherited;
  AllowPause := False;
  Interactive := True;
  DisplayName := FDisplayName;
  Name := FServiceName;
  BeforeInstall := ServiceBeforeInstall;
  AfterInstall := ServiceAfterInstall;
  OnStart := Start;
  OnStop := Stop;
end;

//------------------------------------------------------------------------------

procedure TCiaService.ServiceAfterInstall(Sender: TService);
begin
  RegWriteString(HKEY_LOCAL_MACHINE, RegServiceURL + Name, RegDescription,
    ServiceDescription);
  RegWriteString(HKEY_LOCAL_MACHINE, RegServiceURL + Name, RegImagePath,
    ParamStr(0) + ' -svc');
end;

procedure TCiaService.ServiceBeforeInstall(Sender: TService);
begin
  RegValueDelete(HKEY_LOCAL_MACHINE, RegServiceURL + Name, RegDescription);
end;

procedure TCiaService.Start(Sender: TService; var Started: Boolean);
begin
  Started := True;
end;

//------------------------------------------------------------------------------

procedure TCiaService.Execute(Sender: TService);
begin
  while not Terminated do
    ServiceThread.ProcessRequests(True);
end;

//------------------------------------------------------------------------------

procedure TCiaService.Stop(Sender: TService; var Stopped: Boolean);
begin
  Stopped := True;
end;

//------------------------------------------------------------------------------
//---- Various -----------------------------------------------------------------
//------------------------------------------------------------------------------

function CiaIsService: Boolean;
begin
  Result := FIsService;
end;

//------------------------------------------------------------------------------

function CiaStartService(DisplayName: string): Boolean;
var
  Mgr, Svc          : Integer;
  UserName, ServiceStartName: string;
  Config            : Pointer;
  Size              : DWord;
  n                 : Integer;
begin
  FDisplayName := DisplayName;
  FServiceName := DisplayName;

  for n := 1 to Length(FServiceName) do
    if FServiceName[n] = ' ' then
      FServiceName[n] := '_';

  FIsService := FindCmdLineSwitch('svc', ['-', '\', '/'], True) or FindCmdLineSwitch('install', ['-', '\', '/'], True)
    or FindCmdLineSwitch('uninstall', ['-', '\', '/'], True);

  if FIsService then
  begin
    SvcMgr.Application.Initialize;
    CiaService := TCiaService.CreateNew(SvcMgr.Application, 0);
    Result := True;
    Exit;
  end;

  Mgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if Mgr <> 0 then
  begin
    Svc := OpenService(Mgr, PChar(FServiceName), SERVICE_ALL_ACCESS);
    FIsService := Svc <> 0;
    if FIsService then
    begin
      QueryServiceConfig(Svc, nil, 0, Size);
      Config := AllocMem(Size);
      try
        QueryServiceConfig(Svc, Config, Size, Size);
        ServiceStartName := PQueryServiceConfig(Config)^.lpServiceStartName;
        if CompareText(ServiceStartName, 'LocalSystem') = 0 then
          ServiceStartName := 'SYSTEM';
      finally
        Dispose(Config);
      end;
      CloseServiceHandle(Svc);
    end;
    CloseServiceHandle(Mgr);
  end;

  if FIsService then
  begin
    Size := 256;
    SetLength(UserName, Size);
    GetUserName(PChar(UserName), Size);
    SetLength(UserName, StrLen(PChar(UserName)));
    FIsService := CompareText(UserName, ServiceStartName) = 0;
  end;

  Result := FIsService;

  if FIsService then
  begin
    SvcMgr.Application.Initialize;
    CiaService := TCiaService.CreateNew(SvcMgr.Application, 0);
  end;
end;

end.

3.注册运行：install.bat

@ECHO OFF
setlocal EnableDelayedExpansion
color 3e
title 66666
 
PUSHD %~DP0 & cd /d "%~dp0"
%1 %2
mshta vbscript:createobject("shell.application").shellexecute("%~s0","goto :runas","","runas",1)(window.close)&goto :eof
:runas
 
::写自己的代码
SCLQData.exe /install
net start SCLQData

4.删除服务:uninstall.bat

@ECHO OFF
setlocal EnableDelayedExpansion
color 3e
title 66666
 
PUSHD %~DP0 & cd /d "%~dp0"
%1 %2
mshta vbscript:createobject("shell.application").shellexecute("%~s0","goto :runas","","runas",1)(window.close)&goto :eof
:runas
 
::写自己的代码
SCLQData.exe /install
net start SCLQData

4.开机启动

delphi 创建windows 服务应用

Guess you like