1、关于TServiceManager控件

WIKI以上内容很少，只能判断服务是否存在代码(不能遍历所有服务，调用Services.Items是空的）： program ServiceTest; // Check if a certain process is running. { KaTeX parse error: Expected 'EOF', got '}' at position 12: mode objfpc}?{ H } uses Classes, SysUtils, ServiceManager, JwaWinSvc {for services declarations};

const ServiceToTest = ‘SamSs’;

//Security Accounts Manager, should be running, at least on Vista begin WriteLn(‘Starting test for ’ ServiceToTest ’ service.’); if IsServiceRunning(ServiceToTest) then WriteLn(‘The ’ ServiceToTest ’ service is running’) else WriteLn(‘The ’ ServiceToTest ’ service is not running’); end.

在https://forum.lazarus.freepascal.org/index.php/topic,59497.msg443560.html#msg443560上找到代码：首先是Access设置属性值，然后设置属性值RefreshOnConnect应该置为TURE: procedure TForm1.Button1Click(Sender: TObject); var Num_of_Services: longint; i: Integer; entry: TServiceEntry; begin

servicemanager1.Access := SC_MANAGER_ALL_ACCESS; ServiceManager1.RefreshOnConnect := True; ServiceManager1.Connect();

Num_of_Services := serviceManager1.Services.Count;

for i := 0 to Num_of_Services -1 do begin entry := serviceManager1.Services[i]; memo1.Lines.Add (entry.DisplayName ’ : ’ ServiceStateName(entry.CurrentState)); end; end;

2、进程管理

2.1、Delphi下的例子

我在网上找到的例子和我在网上找到的例子Delphi下测试没有问题(通过(通过)TCP保持握手信号的状态): unit WatchDog_ut;

interface

uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.ExtCtrls, Vcl.StdCtrls, Winapi.ShellApi, Web.Win.Sockets, Vcl.Grids, Vcl.ValEdit, System.IniFiles;

type TProcessObject=class private FWaitCount: integer; FUseWatch: boolean; procedure SetWaitCount(const Value: integer); procedure SetUseWatch(const Value: boolean); public LogList:TListBox; ///测试输出 ProcessName:string; //过程名称，操作程序文件名称 ProcessTitle:string; ///程序标题 ProcessHandle:Cardinal; ///进程句柄 ProcessState:integer; //状态：-1 未启动； 0：启动进程； 1:正常运行(接收握手) ProcessWaitTime:integer; //等待时间。如果此时到达，程序仍然没有握手信号，则认为程序已关闭，需要杀死程序并重启程序 property UseWatch:boolean read FUseWatch write SetUseWatch; //是否护理 property WaitCount:integer read FWaitCount write SetWaitCount; ///延时计数器

procedure CloseProcess;        //强杀进程 procedure StartProcess;        //启动程序 function FindProcess:boolean;   ///搜索过程 ，如果没有程序连接，主动查找过程并Kill之，不管有没有，都要启动程序

end;

TWatchDogForm = class(TForm) TrayIcon1: TTrayIcon; PopupMenu1: TPopupMenu; N1: TMenuItem; N2: TMenuItem; N3: TMenuItem; N4: TMenuItem; Button1: TButton; Button2: TButton; TcpServer1: TTcpServer; ValueListEditor1: TValueListEditor; Timer1: TTimer; Timer2: TTimer; ListBox1: TListBox; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure Timer1Timer(Sender: TObject); pocedure TcpServer1Accept(Sender: TObject; ClientSocket: TCustomIpClient); procedure Button2Click(Sender: TObject); procedure Button1Click(Sender: TObject); procedure N4Click(Sender: TObject); procedure FormResize(Sender: TObject); procedure TrayIcon1DblClick(Sender: TObject); procedure Timer2Timer(Sender: TObject); private { Private declarations } public { Public declarations } end;

var WatchDogForm: TWatchDogForm; AppPath:string; ProcessList:TList; ProcessNumber:integer; TcpPort:string;

implementation uses TLHelp32; {$R *.dfm}

{ TProcessObject }

procedure TProcessObject.CloseProcess; var s:string; begin if ProcessHandle=0 then FindProcess;

if ProcessHandle<>0 then begin if ProcessState=-2 then Exit;

if TerminateProcess(ProcessHandle,0) then
begin
  CloseHandle(ProcessHandle);
  ProcessHandle:=0;
  ProcessState:=-1;
end
else
begin
  ProcessHandle:=0;
  ProcessState:=2;
end;

end; //测试输出 s:=ProcessName + ‘关闭：’ + DateTimeToStr(now) ; if LogList<>nil then LogList.Items.Append(s); end;

function TProcessObject.FindProcess: boolean; var hSnapshot: THandle; //用于获得进程列表 lppe: TProcessEntry32; //用于查找进程 Found: Boolean; //用于判断进程遍历是否完成 KillHandle: THandle; //用于杀死进程 begin result:=false; if ProcessName<>‘’ then begin hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); //获得系统进程列表 lppe.dwSize := SizeOf(TProcessEntry32); //在调用Process32First API之前，需要初始化lppe记录的大小 Found := Process32First(hSnapshot, lppe); //将进程列表的第一个进程信息读入ppe记录中 while Found do begin if ((UpperCase(ExtractFileName(lppe.szExeFile)) = UpperCase(ProcessName)) or (UpperCase(lppe.szExeFile) = UpperCase(ProcessName))) then begin //ProcessHandle:= lppe.th32ProcessID; ProcessHandle:= OpenProcess(PROCESS_TERMINATE, False, lppe.th32ProcessID); if ProcessHandle<>0 then begin ProcessState:=0; Result := True; end; Exit; end; Found := Process32Next(hSnapshot, lppe); //将进程列表的下一个进程信息读入lppe记录中 end; end; end;

procedure TProcessObject.SetUseWatch(const Value: boolean); begin FUseWatch := Value; if not Value then ProcessState:=-2; end;

procedure TProcessObject.SetWaitCount(const Value: integer); begin FWaitCount := Value; if Value > ProcessWaitTime then begin FWaitCount:=0; if ProcessHandle = 0 then StartProcess else CloseProcess; end; end;

procedure TProcessObject.StartProcess; var i:integer; s:string; begin //if ProcessState=2 then Exit; if ProcessState=-2 then Exit;

if ProcessName<>‘’ then begin if FileExists(ProcessName) then begin i:=ShellExecute(0,‘open’,PWideChar(ProcessName),‘’,‘’,SW_SHOWMINIMIZED); if i<>0 then begin ProcessState:=0; FindProcess; end else ProcessState:=4; end else ProcessState:=3; end; //测试输出 s:=ProcessName + ‘启动：’ + DateTimeToStr(now) ; if LogList<>nil then LogList.Items.Append(s); end;

{WatchDogForm}

procedure TWatchDogForm.Button1Click(Sender: TObject); begin Timer1.Enabled:=false; Button1.Enabled:=false; Button2.Enabled:=true; N2.Enabled:=false; N1.Enabled:=true; ValueListEditor1.Values[‘守护程序[WatchDog.exe]’]:=‘停止守护’; end;

procedure TWatchDogForm.Button2Click(Sender: TObject); begin Timer1.Enabled:=true; Button2.Enabled:=false; Button1.Enabled:=true; N1.Enabled:=false; N2.Enabled:=true; ValueListEditor1.Values[‘守护程序[WatchDog.exe]’]:=‘启动守护’; end;

procedure TWatchDogForm.FormClose(Sender: TObject; var Action: TCloseAction); var po:TProcessObject; i:integer; begin if Application.MessageBox(‘你确定要退出[传感器转发软件守护程序]吗？’,‘确认’,MB_YESNO) = IDYES then begin Timer1.Enabled:=false; if TcpServer1.Active then TcpServer1.Close;

if ProcessNumber>0 then
begin
  if ProcessList<>nil then
  begin
    for i := 0 to ProcessNumber-1 do
    begin
      po:=TProcessObject(ProcessList.Items[i]);
      if po<>nil then po.Free;
    end;
    ProcessList.Free;
  end;
end;
Action:=caFree;

end else Action:=caNone; end;

procedure TWatchDogForm.FormCreate(Sender: TObject); var f:TInifile; i:integer; s:string; po:TProcessObject; begin AppPath:= ExtractFilePath(Paramstr(0)); f:=TInifile.Create(AppPath + ‘WatchDog.ini’); try ProcessNumber:=f.ReadInteger(‘System’,‘ProcessNumber’,0); TcpPort:=f.ReadString(‘System’,‘TcpPort’,‘7780’); if ProcessNumber>0 then begin TcpServer1.LocalHost:=‘localhost’; TcpServer1.LocalPort:=TcpPort; TcpServer1.Open; ProcessList:=TList.Create; for i := 1 to ProcessNumber do begin po:=TProcessObject.Create; po.LogList:=ListBox1; s:=‘Process’ + IntToStr(i); po.ProcessName:=f.ReadString(s,‘ProcessName’,‘’); po.ProcessTitle:=f.ReadString(s,‘ProcessTitle’,‘’); po.ProcessHandle:=0; po.ProcessState:=-1; po.ProcessWaitTime:=f.ReadInteger(s,‘ProcessWaitTime’,60); po.UseWatch:=f.ReadBool(s,‘UseWatch’,false); po.FindProcess; ProcessList.Add(po); end; end; finally f.Free; end; Button2.Click; end;

procedure TWatchDogForm.FormResize(Sender: TObject); begin if Application.MainForm.WindowState = wsMinimized then begin Application.MainForm.Hide; end; end;

procedure TWatchDogForm.N4Click(Sender: TObject); begin Close; end;

procedure TWatchDogForm.TcpServer1Accept(Sender: TObject; ClientSocket: TCustomIpClient); var s:string; i,h:integer; po:TProcessObject; s1,s2:string; m,n:integer; begin s:=ClientSocket.Receiveln; while s<>‘’ do begin if ProcessNumber >0 then begin if ProcessList<>nil then begin m:=Length(s); n:=Pos(‘#’,s); if n>0 then begin s1:=copy(s,1,n-1); s2:=copy(s,n+1,m-n); for i := 0 to ProcessNumber-1 do begin po:=TProcessObject(ProcessList.Items[i]); if po<>nil then begin if po.ProcessName = s1 then begin if s2<>‘1’ then po.ProcessState:=-2 else po.ProcessState:=1; po.WaitCount:=0; end; end; end; end; end; end; s:=ClientSocket.Receiveln; end; end;

procedure TWatchDogForm.Timer1Timer(Sender: TObject); var i:integer; po:TProcessObject; s:string; begin if TcpServer1.Active = false then Exit;

if ProcessNumber>0 then begin if ProcessList<>nil then begin for i := 0 to ProcessNumber-1 do begin po:=TProcessObject(ProcessList.Items[i]); if po<>nil then begin if po.UseWatch then po.WaitCount:=po.WaitCount+1;

      case po.ProcessState  of
        -2:s:='程序自主运行';
        -1:s:='程序未启动';
        0:s:='程序已启动';
        1:s:='程序运行中...';
        2:s:='程序异常，无法关闭';
        3:s:='程序文件未找到';
        4:s:='程序启动异常';
      end;
      ValueListEditor1.Values[po.ProcessTitle + '['+po.ProcessName +']']:=s;//+'['+DateTimeToStr(now) + ']';
    end;
  end;
end;

end; end;

procedure TWatchDogForm.Timer2Timer(Sender: TObject); begin Application.MainForm.WindowState:=wsMinimized; Timer2.Enabled:=false; end;

procedure TWatchDogForm.TrayIcon1DblClick(Sender: TObject); begin Application.MainForm.Show; Application.MainForm.WindowState := wsNormal; end;

end.

2.2、Lazarus下应用（Lazarus 2.0.10 + Windows10)

首先在非wince下是没有TLHelp32这个单元的，而且在wince下shellApi和TLHelp32均是简化的，好多函数是没有的，强行增加这个单元也会出现编译错误，还得在英文论坛上找（英文不好，实在不想看外文网站）：https://forum.lazarus.freepascal.org/index.php?action=search2，在这个页面上搜索TLHelp32出现由这个可以看出，在Lazarus下用JwaTlHelp32, jwawinbase, jwawinnt…代替TlHelp32单元，在工程中增加这些单元，果然函数和定义均可用。

随记 2022.6.24 于合肥

资讯详情

Lazarus进行Windows下服务和进程的管理

1、关于TServiceManager控件

2、进程管理

2.1、Delphi下的例子

2.2、Lazarus下应用（Lazarus 2.0.10 + Windows10)

关于STC单片机的一些牢骚

Lazarus进行Windows下服务和进程的管理

1、关于TServiceManager控件

2、进程管理

2.1、Delphi下的例子

2.2、Lazarus下应用（Lazarus 2.0.10 + Windows10)

关于STC单片机的一些牢骚

最近热搜

历史搜索 清除历史记录

历史搜索清除历史记录