服务端守护程序

      写程序有时候总是会碰到很多莫名其妙的问题，前两天LIS中间件 加载血气分析仪dll后总是无故自动关闭了，找了一天的av错误，项目现场催着验收，没办法就找了这个折中的法子。 （思路）写一个服务端守护程序，当守护程序检测不到服务端程序的时候 就自动开启服务端程序。

全部源码 我已经上传到 ：

http://download.csdn.net/detail/u013051638/9789543

Q群 Delphi Home 235236282，QQ:359985051/183902633 

诚邀delphi 爱好者加入，一起学习，研究、探讨。

1、在线程中添加一个FindProcess方法  AFileName是服务端程序的路径

function TautoStart.FindProcess(AFileName: string): boolean;//查找Pserver程序是否开启
var
  hSnapshot: THandle; //用于获得进程列表
  lppe: TProcessEntry32; //用于查找进程
  Found: Boolean; //用于判断进程遍历是否完成
begin
  Result := False;
  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(AFileName)) or (UpperCase(lppe.szExeFile) = UpperCase(AFileName))) then
    begin
      GHandle := hSnapshot;
      Result := True;
      Break;
    end;
    Found := Process32Next(hSnapshot, lppe); //将进程列表的下一个进程信息读入lppe记录中
  end;
end;

2、在线程的Execute事件中 不停的循环检测服务端程序是否运行 没有运行则开启外部服务端程序。

procedure TautoStart.Execute;
var
  filename: string;
begin
  inherited;
  filename := 'Pserver.exe'; //服务端程序的路径 我把守护程序和Pserver放一起了

  while not Terminated do
  begin
    if not FindProcess(filename) then
    begin
      ShellExecute(Application.Handle, 'open', PChar(filename), nil, nil, SW_SHOWNORMAL);
      Sleep(1000);
    end;
    Sleep(1000);
  end;

end;

整个守护程序中还有一个最小化托盘和关闭外部程序的代码，详情请看下面的单元文件：

unit umain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, RzPanel;

const
  NIF_INFO = $00000010;          //气泡显示标志
  NIIF_NONE = $00000000;          //无图标
  NIIF_INFO = $00000001;          //信息图标
  NIIF_WARNING = $00000002;          //警告图标
  NIIF_ERROR = $00000003;          //错误图标
  NIIF_USER = $00000004;          //XP使用hIcon图标

type
  TNotifyIconDataEx = record
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
    szTip: array[0..127] of AnsiChar;
    dwState: DWORD;
    dwStateMask: DWORD;
    szInfo: array[0..255] of AnsiChar;
    case Integer of
      0:
        (uTimeout: UINT);
      1:
        (uVersion: UINT;
        szInfoTitle: array[0..63] of AnsiChar;
        dwInfoFlags: DWORD);
  end;

const
  WM_TRAYMSG = WM_USER + 1001;                   //自定义托盘消息

type
  TautoStart = class(TThread)
  private
    function FindProcess(AFileName: string): boolean;
  protected
    procedure Execute; override;
  end;

type
  TForm1 = class(TForm)
    RzPanel1: TRzPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    procedure WMTrayMsg(var Msg: TMessage); message WM_TRAYMSG;    //声明托盘消息
    procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
    function KillAppExe(const aPathExe: string): Boolean;
  public
    { Public declarations }

    autoStart: TautoStart;
  end;

var
  Form1: TForm1;
  NotifyIcon: TNotifyIconDataEx;                    //定义托盘图标结构体
implementation

{$R *.dfm}

uses
  ShellAPI, TLHelp32; 

{ TautoStart }

procedure TautoStart.Execute;
var
  filename: string;
begin
  inherited;
  filename := 'Pserver.exe'; //服务端程序的路径 我把守护程序和Pserver放一起了

  while not Terminated do
  begin
    if not FindProcess(filename) then
    begin
      ShellExecute(Application.Handle, 'open', PChar(filename), nil, nil, SW_SHOWNORMAL);
      Sleep(1000);
    end;
    Sleep(1000);
  end;

end;

function TautoStart.FindProcess(AFileName: string): boolean;//查找Pserver程序是否开启
var
  hSnapshot: THandle; //用于获得进程列表
  lppe: TProcessEntry32; //用于查找进程
  Found: Boolean; //用于判断进程遍历是否完成
begin
  Result := False;
  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(AFileName)) or (UpperCase(lppe.szExeFile) = UpperCase(AFileName))) then
    begin
         Result := True;
      Break;
    end;
    Found := Process32Next(hSnapshot, lppe); //将进程列表的下一个进程信息读入lppe记录中
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  with NotifyIcon do
  begin
    cbSize := SizeOf(TNotifyIconDataEx);
    Wnd := Self.Handle;
    uID := 1;
    uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP + NIF_INFO;   //图标、消息、提示信息
    uCallbackMessage := WM_TRAYMSG;
    hIcon := Application.Icon.Handle;
    szTip := 'PserverS守护程序';
    szInfo := '守护程序';
    szInfoTitle := 'Pserver守护';
    dwInfoFlags := NIIF_USER;
  end;
  Shell_NotifyIcon(NIM_ADD, @NotifyIcon);

  autoStart := TautoStart.Create(True);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_DELETE, @NotifyIcon);

  autoStart.Terminate;
  autoStart.WaitFor;
  autoStart.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  autoStart.Resume;
end;

procedure TForm1.WMSysCommand(var Msg: TMessage);
begin
  if Msg.WParam = SC_ICON then
    Self.Visible := False
  else
    DefWindowProc(Self.Handle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
{-------------------------------------------------------------------------------
 Description: 自定义的托盘消息 
-------------------------------------------------------------------------------}

procedure TForm1.WMTrayMsg(var Msg: TMessage);
var
  p: TPoint;
begin
  case Msg.LParam of
    WM_LBUTTONDOWN:
      Self.Visible := True;   //显示窗体
    WM_RBUTTONDOWN:
      begin
        SetForegroundWindow(Self.Handle);   //把窗口提前
        GetCursorPos(p); 
      end;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  lsbool: Boolean;
begin
  lsbool := KillAppExe('Pserver.exe');//关闭程序
  while not lsbool do
  begin
    lsbool := KillAppExe('Pserver.exe');
  end;

end;

function TForm1.KillAppExe(const aPathExe: string): Boolean;//关闭外部Pserver服务端程序
const
  PROCESS_TERMINATE = $0001;
var
  _vHandle: THandle;
  _vProEntry: TProcessEntry32;
  _vIsFound: Boolean;
  _vTempStr: string;
begin
  Result := False;
  _vHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  try
    _vProEntry.dwSize := SizeOf(_vProEntry);
    _vIsFound := Process32First(_vHandle, _vProEntry);
    while _vIsFound do
    begin
      _vTempStr := _vProEntry.szExeFile;
      if (UpperCase(_vTempStr) = UpperCase(ExtractFileName(aPathExe))) or (UpperCase(_vTempStr) = UpperCase(aPathExe)) then
      begin
        Result := TerminateProcess(OpenProcess(PROCESS_TERMINATE, Boolean(0), _vProEntry.th32ProcessID), 0);
      end;
      _vIsFound := Process32Next(_vHandle, _vProEntry);
    end;
  finally
    CloseHandle(_vHandle);
  end;
end;

end.

窗体文件

object Form1: TForm1
  Left = 192
  Top = 133
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = bsSingle
  Caption = '服务端守护程序'
  ClientHeight = 65
  ClientWidth = 306
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object RzPanel1: TRzPanel
    Left = 0
    Top = 0
    Width = 306
    Height = 65
    Align = alClient
    BorderOuter = fsNone
    Caption = '服务端守护程序'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlue
    Font.Height = -24
    Font.Name = 'MS Sans Serif'
    Font.Style = [fsBold]
    GradientColorStyle = gcsCustom
    GradientColorStop = clSkyBlue
    ParentFont = False
    TabOrder = 0
    VisualStyle = vsGradient
  end
end