采取下面的方法，可以作一个两栖服务程序
附件是一个简单模版，可以直接使用，包括重复性检测。
首先做一个公共模块，即服务和程序都需要用到的一个部分，以便程序和服务调用。
然后建立窗体，和普通程序一样，然后调用公共模块的功能，然后添加一个Service，同样也调用类似的功能，最后修改Project源代码，修改类似下面：
if ParamStr(1) = '/DEBUG' then
begin
Forms.Application.Initialize;
Forms.Application.CreateForm(TForm1, Form1); ///普通窗体
Forms.Application.CreateForm(TdmWeb, dmWeb); /// 公共模块
Forms.Application.Run;
end
else
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TSvrWeb, SvrWeb); /// 服务窗体
SvcMgr.Application.CreateForm(TdmWeb, dmWeb); /// 公共模块
SvcMgr.Application.Run;
end;
这样，带/DEBUG参数，则以普通程序方式运行，若用服务管理器来运行，则作为服务运行。
例如公共模块：
dmPublic，提供Start,Stop方法。
在主窗体中，调用dmPublic.Start，dmPublic.Stop方法。
同样在Service中，调用dmPublic.Start，dmPublic.Stop方法。
---------------------------------------
Here's what you need to do to make a Delphi service use it....
Original service project file looks like this...
program TestService;
uses
SvcMgr,
TestServiceImpl in 'TestServiceImpl.pas' {Service1: TService};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TService1, Service1);
Application.Run;
end.
Modify the project file to look like this...
program TestService;
uses
SvcMgr,
unitDebugService,
TestServiceImpl in 'TestServiceImpl.pas' {Service1: TService};
{$R *.RES}
var debugMode : boolean;
begin
debugMode := False;
if (paramCount > 0) and (SameText (ParamStr (1), '-DEBUG')) then
begin
FreeAndNil (Application);
Application := TDebugServiceApplication.Create(nil);
debugMode := True;
end;
Application.Initialize;
Application.CreateForm(TService1, Service1);
// Service1.DebugMode := debugMode; Optionally create a global
// DebugMode variable in your
// service, and set it here.
Application.Run;
end.
---------------------------------------
unit unitDebugService;
interface
uses Windows, Messages, Consts, Classes, SysUtils, Forms, SvcMgr;
type
//---------------------------------------------------------------------
// TDebugServiceApplication class
TDebugServiceApplication = class (TServiceApplication)
private
procedure OnExceptionHandler(Sender: TObject; E: Exception);
public
procedure Run; override;
destructor Destroy; override;
procedure TerminateThreads (all : boolean);
end;
//---------------------------------------------------------------------
// TDebugServiceThread class
TDebugServiceThread = class (TThread)
private
fService : TService;
procedure ProcessRequests(WaitForMessage: Boolean);
protected
procedure Execute; override;
public
constructor Create (AService : TService);
end;
implementation
{ TDebugServiceApplication }
destructor TDebugServiceApplication.Destroy;
begin
try
inherited;
except
MessageBeep ($ffff);
end
end;
(*----------------------------------------------------------------------*
| procedure TDebugServiceApplication.OnExceptionHandler |
| |
| Handler for VCL exceptions |
| |
| Parameters: |
| Sender: TObject; E: Exception |
*----------------------------------------------------------------------*)
procedure TDebugServiceApplication.OnExceptionHandler(Sender: TObject; E: Exception);
begin
DoHandleException(E);
end;
(*----------------------------------------------------------------------*
| procedure TDebugServiceApplication.Run |
| |
| Run the service
*----------------------------------------------------------------------*)
procedure TDebugServiceApplication.Run;
var
i : Integer;
service : TService;
thread : TThread;
begin
Forms.Application.OnException := OnExceptionHandler;
try
// Create a TDebugServiceThread for each of the services
for i := 0 to ComponentCount - 1 do
if Components [i] is TService then
begin
service := TService (Components [i]);
thread := TDebugServiceThread.Create(service);
thread.Resume;
service.Tag := Integer (thread);
end;
// Run the 'service'
while not Forms.Application.Terminated do
Forms.Application.HandleMessage;
// Terminate each TDebugServiceThread
TerminateThreads (True)
finally
end;
end;
{ TDebugServiceThread }
(*----------------------------------------------------------------------*
| constructor TDebugServiceThread.Create |
| |
| Constructor for TDebugServiceThread |
*----------------------------------------------------------------------*)
constructor TDebugServiceThread.Create(AService: TService);
begin
fService := AService;
inherited Create (True);
end;
(*----------------------------------------------------------------------*
| procedure TDebugServiceThread.Execute |
| |
| 'Execute' method fot TDebugServiceThread. Process messages |
*----------------------------------------------------------------------*)
procedure TDebugServiceThread.Execute;
var
msg: TMsg;
Started: Boolean;
begin
PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE); { Create message queue }
try
Started := True;
if Assigned(FService.OnStart) then FService.OnStart(FService, Started);
if not Started then
begin
PostMessage (Forms.Application.Handle, WM_QUIT, 0, 0);
ProcessRequests (True);
Exit
end;
try
if Assigned(FService.OnExecute) then
FService.OnExecute(FService)
else
ProcessRequests(True);
ProcessRequests(False);
except
on E: Exception do
FService.LogMessage(Format(SServiceFailed,[SExecute, E.Message]));
end;
except
on E: Exception do
begin
FService.LogMessage(Format(SServiceFailed,[SStart, E.Message]));
PostMessage (Forms.Application.Handle, WM_QUIT, 0, 0);
end
end;
end;
(*----------------------------------------------------------------------*
| procedure TDebugServiceThread.ProcessRequests |
| |
| 'ProcessRequests' method. do a message loop. |
*----------------------------------------------------------------------*)
procedure TDebugServiceThread.ProcessRequests(WaitForMessage: Boolean);
var
msg: TMsg;
Rslt, stopped: Boolean;
begin
while True do
begin
if Terminated and WaitForMessage then break;
if WaitForMessage then
Rslt := GetMessage(msg, 0, 0, 0)
else
Rslt := PeekMessage(msg, 0, 0, 0, PM_REMOVE);
if not Rslt then // No message received, or WM_QUIT
begin
if not WaitForMessage then
break;
// WM_QUIT received. Terminate loop - if we're allowed
stopped := True;
if Assigned (fService.OnStop) then
fService.OnStop (fService, stopped);
if stopped then
break
end
else
DispatchMessage(msg);
end;
end;
procedure TDebugServiceApplication.TerminateThreads (all : boolean);
var
i, n : Integer;
service : TService;
thread : TThread;
begin
if all then
n := 0
else
n := 1;
for i := ComponentCount - 1 downto n do
if Components [i] is TService then
begin
service := TService (Components [i]);
thread := TThread (service.Tag);
if Assigned (thread) then
begin
PostThreadMessage (thread.ThreadID, WM_QUIT, 0, 0);
thread.WaitFor;
FreeAndNil (thread)
end;
service.Tag := 0;
end;
end;
end.