Delphi利用多线程创建系统服务

最新推荐文章于 2022-06-11 14:57:51 发布

原创最新推荐文章于 2022-06-11 14:57:51 发布 · 828 阅读

0 ·

CC 4.0 BY-SA版权

文章标签：

#delphi #多线程 #integer #class #application #string

Delphi 专栏收录该内容

0 篇文章

订阅专栏

本文介绍如何使用Delphi通过多线程创建一个系统服务，该服务开机自动运行，能检测特定程序是否运行，如果程序未运行则每5秒显示提示消息。服务设置了交互模式，并在关机时释放资源以确保正常关机。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

程序功能：创建系统服务，开机自动运行，监测某一程序是否正在运行，如果没有运行，则每隔5秒弹出一个提示消息框

程序实现：

1、启动Delphi6.0或者7.0 File->New->Other...->Service Application

2、设置服务属性 Interactive := True; DisplayName := '监测当前进程'; Name := 'InspectService';(Interactive := True确保服务可以与桌面交互)

3、添加新的Form，Unit名称Unit_FrmMain，Form名称FrmMain

4、编写弹出消息线程：MessageThread

特别注意：一定要编写关机事件并注册，否则由于服务不能停止导致无法关机

程序源代码如下：

工程文件

Program InspectExe; 
Uses 
  SvcMgr, 
  Unit_Main In 'Unit_Main.pas' {InspectService: TService}, 
  Unit_FrmMain In 'Unit_FrmMain.pas' {FrmMain}; 
{$R *.RES} 
Begin 
  Application.Initialize; 
  Application.CreateForm(TInspectService, InspectService); 
  Application.Run; 
End. 

服务单元

Unit Unit_Main; 
Interface 
Uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, WinSvc, 
  Unit_FrmMain; 
Type 
  TInspectService = Class(TService) 
    Procedure ServiceContinue(Sender: TService; Var Continued: Boolean); 
    Procedure ServiceExecute(Sender: TService); 
    Procedure ServicePause(Sender: TService; Var Paused: Boolean); 
    Procedure ServiceShutdown(Sender: TService); 
    Procedure ServiceStart(Sender: TService; Var Started: Boolean); 
    Procedure ServiceStop(Sender: TService; Var Stopped: Boolean); 
  private 
    { Private declarations } 
  public 
    Function GetServiceController: TServiceController; override; 
    Constructor CreateNew(AOwner: TComponent; Dummy: Integer); override; 
    { Public declarations } 
  End; 
Var 
  InspectService: TInspectService; 
  FrmMain: TFrmMain; 
Implementation 
{$R *.DFM} 
Constructor TInspectService.CreateNew(AOwner: TComponent; Dummy: Integer); 
Begin 
  Inherited CreateNew(AOwner, Dummy); 
  AllowPause := True; 
  Interactive := True; 
  DisplayName := '监测当前进程'; 
  Name := 'InspectService'; 
  //OnContinue := ServiceContinue;  
  //OnPause := ServicePause;  
  OnShutdown := ServiceShutdown; 
  OnStart := ServiceStart; 
  OnStop := ServiceStop; 
End; 
Procedure ServiceController(CtrlCode: DWord); stdcall; 
Begin 
  InspectService.Controller(CtrlCode); 
End; 
Function TInspectService.GetServiceController: TServiceController; 
Begin 
  Result := ServiceController; 
End; 
Procedure TInspectService.ServiceContinue(Sender: TService; 
  Var Continued: Boolean); 
Begin 
  While Not Terminated Do 
  Begin 
    Sleep(10); 
    ServiceThread.ProcessRequests(False); 
  End; 
End; 
Procedure TInspectService.ServiceExecute(Sender: TService); 
Begin 
  While Not Terminated Do 
  Begin 
    Sleep(10); 
    ServiceThread.ProcessRequests(False); 
  End; 
End; 
Procedure TInspectService.ServicePause(Sender: TService; 
  Var Paused: Boolean); 
Begin 
  Paused := True; 
End; 
Procedure TInspectService.ServiceShutdown(Sender: TService); 
Begin 
  BCanClose := True; 
  WorkStus := False;//关机的时候停止发送消息，确保能够正常关机  
  FrmMain.Free; 
  Status := csStopped; 
  ReportStatus(); 
End; 
Procedure TInspectService.ServiceStart(Sender: TService; 
  Var Started: Boolean); 
Begin 
  Started := True; 
  SvcMgr.Application.CreateForm(TFrmMain, FrmMain); 
  BCanClose := False; 
  WorkStus := True; 
  FrmMain.Hide; 
  //WriteErrLog('<' + FormatDateTime('YYYY-MM-DD HH:NN:SS', Now) + '>' + 'InspectService is started');  
End; 
Procedure TInspectService.ServiceStop(Sender: TService; 
  Var Stopped: Boolean); 
Begin 
  Stopped := True; 
  BCanClose := True; 
  WorkStus := False; 
  FrmMain.Free; 
End; 
End. 

新添加的Form

Unit Unit_FrmMain; 
Interface 
Uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, ExtCtrls, TlHelp32; 
Type 
  TFrmMain = Class(TForm) 
    Procedure FormCreate(Sender: TObject); 
    Procedure FormCloseQuery(Sender: TObject; Var CanClose: Boolean); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  End; 
Type 
  MessageThread = Class(TThread) {发送消息线程} 
  private 
    { Private declarations } 
  protected 
    Procedure Execute; override; 
  public 
    Constructor Create(); 
    Procedure SendMessage; 
    Function InspectProcedureExists(ExeName: String): Boolean; 
    { Public declarations } 
  End; 
Var 
  FrmMain: TFrmMain; 
  BCanClose: Boolean; 
  WorkStus: Boolean; {是否启用发送消息线程} 
  objThread: MessageThread; 
Implementation 
{$R *.dfm} 
Constructor MessageThread.Create(); 
Begin 
  FreeOnTerminate := True; 
  Inherited Create(False); 
  WorkStus := True; 
End; 
Procedure MessageThread.Execute; 
Begin 
  While WorkStus Do 
  Begin 
    Sleep(5000); 
    Application.ProcessMessages; 
    Synchronize(SendMessage); 
  End; 
End; 
Procedure MessageThread.SendMessage; 
Var 
  ExeName: String; 
Begin 
  ExeName := 'test.exe'; 
  If Not InspectProcedureExists(ExeName) Then 
    MessageDlg(ExeName + '未启动', mtinformation, [mbok], 0); 
End; 
{判断系统当前进程中是否存在指定的Exe名称} 
Function MessageThread.InspectProcedureExists(ExeName: String): Boolean; 
Var 
  hSnapshot: THandle; 
  lppe: TProcessEntry32; 
  Found: Boolean; 
Begin 
  Result := False; 
  hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); 
  lppe.dwSize := SizeOf(TProcessEntry32); 
  Found := Process32First(hSnapshot, lppe); 
  While Found Do 
  Begin 
    If ((UpperCase(ExtractFileName(lppe.szExeFile)) = UpperCase(ExeName)) Or (UpperCase(lppe.szExeFile) = UpperCase('ExeName'))) Then 
    Begin 
      Result := True; 
      break; 
    End; 
    Found := Process32Next(hSnapshot, lppe); 
  End; 
End; 
{ TFrmMain } 
Procedure TFrmMain.FormCreate(Sender: TObject); 
Begin 
  SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); 
  BCanClose := False; 
  objThread := MessageThread.Create; 
End; 
Procedure TFrmMain.FormCloseQuery(Sender: TObject; Var CanClose: Boolean); 
Begin 
  BCanClose := CanClose; 
  If Not CanClose Then 
  Begin 
    Hide; 
  End; 
End; 
End. 