写程序有时候总是会碰到很多莫名其妙的问题,前两天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;
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