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.开机启动