从网上找的例子,源来的忘了,记得最开始是一个图标,后来不知道为什么出现了两个图标。当服务停止时就报错,一个的时候没有报错!请大侠们帮忙看看!unit LMS;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,Unit_FrmMain,WinSvc,registry,IniFiles;
type
THC_LMS_Service = 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);
procedure ServiceAfterInstall(Sender: TService);
procedure SetDescription;
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;var
HC_LMS_Service: THC_LMS_Service;
frmMain:TfrmMain;
implementation{$R *.DFM}procedure ServiceController(CtrlCode: DWord); stdcall;
begin
HC_LMS_Service.Controller(CtrlCode);
end;function THC_LMS_Service.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;procedure THC_LMS_Service.ServiceContinue(Sender: TService;
var Continued: Boolean);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;procedure THC_LMS_Service.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;procedure THC_LMS_Service.ServicePause(Sender: TService;
var Paused: Boolean);
begin
Paused := True;
end;procedure THC_LMS_Service.ServiceShutdown(Sender: TService);
begin
gbCanClose := true;
FrmMain.Free;
Status := csStopped;
ReportStatus();
end;
/// <example>
/// <code>
/// 启动服务
/// </code>
/// </example>
procedure THC_LMS_Service.ServiceStart(Sender: TService;var Started: Boolean);
begin
Started := True;
Svcmgr.Application.CreateForm(TFrmMain, FrmMain);
gbCanClose := False;
//读配置文件
// frmMain.T_pro.Enabled
FrmMain.Hide;
end;procedure THC_LMS_Service.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := True;
gbCanClose := True;
FrmMain.Free;
end;
procedure THC_LMS_Service.ServiceAfterInstall(Sender: TService);
begin
// 设置服务描述信息
self.SetDescription;
end;procedure THC_LMS_Service.SetDescription;
var
reg:TRegistry;//注册表对象
ConfigIni:TIniFile;
Desc:string;
begin
ConfigIni :=TIniFile.Create('LMS_Config.ini');
reg:=tregistry.create;
try
Desc :=ConfigIni.ReadString('Appinfo','Description','华创公司数据处理程序');
if Desc <>'' then
begin
reg.rootkey:=HKEY_LOCAL_MACHINE;
with reg do
begin
if KeyExists('SYSTEM\\ControlSet001\\Services\\HC_LMS_Service') then
begin
if OpenKey('SYSTEM\\ControlSet001\\Services\\HC_LMS_Service',True) then
begin
WriteString('Description',Desc); end;
end;
end;
end;
finally
Reg.CloseKey;
reg.Free ;
ConfigIni.Free;
end;
end;
end.
unit Unit_FrmMain;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Menus, ComCtrls, ImgList,IniFiles, DB, ADODB,
Grids, DBGrids;const
WM_TrayIcon = WM_USER + 1234;type
TfrmMain = class(TForm)
StatusBar1: TStatusBar;
T_pro: TTimer;
Memo1: TMemo;
ADOConnection1: TADOConnection;
ADOConnection2: TADOConnection;
ADOQuery1: TADOQuery;
ADOQuery2: TADOQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure T_proTimer(Sender: TObject);
//procedure Button1Click(Sender: TObject);
private
{ Private declarations }
IconData: TNotifyIconData;
procedure AddIconToTray;
procedure DelIconFromTray;
procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
procedure SysButtonMsg(var Msg: TMessage); message WM_SYSCOMMAND;
procedure ReadConfigInfo;
public
{ Public declarations }
///配置文件信息变量
AppName,Desc,SDB,TDB,LogFilePath:string;
TimeSet:Integer;
procedure SetApplicationLog(ErrorTime,ErrorInfo:string);
end;var
frmMain: TfrmMain;
gbCanClose: Boolean;implementationuses LMS;{$R *.dfm}
/// <example>
/// <code>
/// 读取配置文件信息
/// </code>
/// </example>
procedure TFrmMain.ReadConfigInfo;
var
ConfigIni:TIniFile;
begin
ConfigIni :=TIniFile.Create('LMS_Config.ini');
AppName:=ConfigIni.ReadString('Appinfo','Name','数据处理程序');
Desc:=ConfigIni.ReadString('Appinfo','Description','数据处理程序');
SDB :=ConfigIni.ReadString('DataSet','SDB',''); //源数据库链接
TDB :=ConfigIni.ReadString('DataSet','TDB',''); //目标数据库链接
TimeSet := ConfigIni.ReadInteger('TimeSet','Time',1); //取数据时间设置
LogFilePath :=ConfigIni.ReadString('Appinfo','LogFilePath','D:\LMS_Log.log'); //日志文件路径
ConfigIni.Free;
end;
procedure TFrmMain.FormCreate(Sender: TObject);
begin
ReadConfigInfo;
frmMain.Caption :=AppName;
FormStyle := fsStayOnTop; {窗口最前}
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); {不在任务栏显示}
gbCanClose := False;
T_pro.Enabled :=False;
AddIconToTray;
//SetApplicationLog(DateTimeToStr(Date),'程序启动');
try
ADOConnection1.ConnectionString:=SDB;
ADOConnection1.Connected :=true;
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('SELECT * FROM ST');
ADOQuery1.Open;
SetApplicationLog(DateTimeToStr(Date),'初始化连接目标数据库成功');
ADOConnection2.ConnectionString:=TDB;
ADOConnection2.Connected :=True;
ADOQuery2.Close;
ADOQuery2.SQL.Clear;
ADOQuery2.SQL.Add('SELECT * FROM TT');
ADOQuery2.Open;
SetApplicationLog(DateTimeToStr(Date),'初始化连接目标数据库成功');
T_pro.Enabled :=True;
T_pro.Interval :=TimeSet*1000;
except
on E:Exception do
SetApplicationLog(DateTimeToStr(Date),'初始化数据环境出错。详细信:'+e.Message);
end;
end;procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := gbCanClose;
if not CanClose then
begin
Hide;
end;
end;procedure TFrmMain.FormDestroy(Sender: TObject);
begin
ADOConnection1.Connected :=false;
ADOConnection2.Connected :=false;
DelIconFromTray;
end;
/// <example>
/// <code>
/// 添加托盘图标
/// </code>
/// </example>
procedure TFrmMain.AddIconToTray;
begin
ZeroMemory(@IconData, SizeOf(TNotifyIconData));
IconData.cbSize := SizeOf(TNotifyIconData);
IconData.Wnd := Handle;
IconData.uID := 1;
IconData.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
IconData.uCallbackMessage := WM_TrayIcon;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := '地衡数据处理程序';
Shell_NotifyIcon(NIM_ADD, @IconData);
end;procedure TFrmMain.DelIconFromTray;
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
end;procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
if (Msg.wParam = SC_CLOSE) or (Msg.wParam = SC_MINIMIZE) then
Hide
else inherited; // 执行默认动作
end;procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
//var
// p:TPoint;
begin
//双击显示主程序
if (Msg.LParam = WM_LBUTTONDBLCLK) then
Show();
//右键显示菜单 为安全性关闭此功能
// if (Msg.LParam =WM_RBUTTONDOWN) then
// begin
// GetCursorPos(p);
// PopupMenu1.Popup(p.x,p.y);
// end;end;procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
// AddIconToTray;
end;procedure SendHokKey;stdcall;
var
HDesk_WL: HDESK;
begin
HDesk_WL := OpenDesktop ('Winlogon', 0, False, DESKTOP_JOURNALPLAYBACK);
if (HDesk_WL <> 0) then
if (SetThreadDesktop (HDesk_WL) = True) then
PostMessage(HWND_BROADCAST, WM_HOTKEY, 0, MAKELONG (MOD_ALT or MOD_CONTROL, VK_DELETE));
end;
/// <example>
/// <code>
/// 数据处理程序
/// </code>
/// </example>
procedure TfrmMain.T_proTimer(Sender: TObject);
begin
try
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('Select * FROM ST');
ADOQuery1.Open;
if ADOQuery1.RecordCount =1 then
begin
ADOQuery2.Close;
ADOQuery2.SQL.Clear;
ADOQuery2.SQL.Add('select * from TT Where Item=''CH''');
ADOQuery2.Open;
ADOQuery2.Edit;
ADOQuery2.FieldByName('Item_Value').AsString :=ADOQuery1.fieldByName('CH').AsString;
ADOQuery2.Post;
StatusBar1.Panels[1].Text :='数据处理中...'+ADOQuery2.FieldByName('Item_Value').AsString ;
end;
except
on e:Exception do
begin
if Memo1.Lines.Count >10 then
Memo1.Lines.Clear;
Memo1.Lines.Add(DateToStr(Date)+' '+FormatDateTime('hh:nn:ss',Now())+'--------数据处理过程中出现错误。详细信息如下:'+e.Message);
SetApplicationLog(DateToStr(Date)+' '+FormatDateTime('hh:nn:ss',Now()),'数据处理过程中出现错误。详细信息如下:'+e.Message);
end;
end;
end;
/// <example>
/// <code>
/// 日志记录方法
/// </code>
/// </example>
procedure TFrmMain.SetApplicationLog(ErrorTime,ErrorInfo:string);
var
txt:TextFile;
begin
try
AssignFile(txt, LogFilePath);
Append(txt);
Writeln(txt,'ErrorTime:'+ErrorTime+'-----ErrorInfo:'+ErrorInfo);
CloseFile(txt);
finally end;
end;
end.
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,Unit_FrmMain,WinSvc,registry,IniFiles;
type
THC_LMS_Service = 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);
procedure ServiceAfterInstall(Sender: TService);
procedure SetDescription;
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;var
HC_LMS_Service: THC_LMS_Service;
frmMain:TfrmMain;
implementation{$R *.DFM}procedure ServiceController(CtrlCode: DWord); stdcall;
begin
HC_LMS_Service.Controller(CtrlCode);
end;function THC_LMS_Service.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;procedure THC_LMS_Service.ServiceContinue(Sender: TService;
var Continued: Boolean);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;procedure THC_LMS_Service.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;procedure THC_LMS_Service.ServicePause(Sender: TService;
var Paused: Boolean);
begin
Paused := True;
end;procedure THC_LMS_Service.ServiceShutdown(Sender: TService);
begin
gbCanClose := true;
FrmMain.Free;
Status := csStopped;
ReportStatus();
end;
/// <example>
/// <code>
/// 启动服务
/// </code>
/// </example>
procedure THC_LMS_Service.ServiceStart(Sender: TService;var Started: Boolean);
begin
Started := True;
Svcmgr.Application.CreateForm(TFrmMain, FrmMain);
gbCanClose := False;
//读配置文件
// frmMain.T_pro.Enabled
FrmMain.Hide;
end;procedure THC_LMS_Service.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := True;
gbCanClose := True;
FrmMain.Free;
end;
procedure THC_LMS_Service.ServiceAfterInstall(Sender: TService);
begin
// 设置服务描述信息
self.SetDescription;
end;procedure THC_LMS_Service.SetDescription;
var
reg:TRegistry;//注册表对象
ConfigIni:TIniFile;
Desc:string;
begin
ConfigIni :=TIniFile.Create('LMS_Config.ini');
reg:=tregistry.create;
try
Desc :=ConfigIni.ReadString('Appinfo','Description','华创公司数据处理程序');
if Desc <>'' then
begin
reg.rootkey:=HKEY_LOCAL_MACHINE;
with reg do
begin
if KeyExists('SYSTEM\\ControlSet001\\Services\\HC_LMS_Service') then
begin
if OpenKey('SYSTEM\\ControlSet001\\Services\\HC_LMS_Service',True) then
begin
WriteString('Description',Desc); end;
end;
end;
end;
finally
Reg.CloseKey;
reg.Free ;
ConfigIni.Free;
end;
end;
end.
unit Unit_FrmMain;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Menus, ComCtrls, ImgList,IniFiles, DB, ADODB,
Grids, DBGrids;const
WM_TrayIcon = WM_USER + 1234;type
TfrmMain = class(TForm)
StatusBar1: TStatusBar;
T_pro: TTimer;
Memo1: TMemo;
ADOConnection1: TADOConnection;
ADOConnection2: TADOConnection;
ADOQuery1: TADOQuery;
ADOQuery2: TADOQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure T_proTimer(Sender: TObject);
//procedure Button1Click(Sender: TObject);
private
{ Private declarations }
IconData: TNotifyIconData;
procedure AddIconToTray;
procedure DelIconFromTray;
procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
procedure SysButtonMsg(var Msg: TMessage); message WM_SYSCOMMAND;
procedure ReadConfigInfo;
public
{ Public declarations }
///配置文件信息变量
AppName,Desc,SDB,TDB,LogFilePath:string;
TimeSet:Integer;
procedure SetApplicationLog(ErrorTime,ErrorInfo:string);
end;var
frmMain: TfrmMain;
gbCanClose: Boolean;implementationuses LMS;{$R *.dfm}
/// <example>
/// <code>
/// 读取配置文件信息
/// </code>
/// </example>
procedure TFrmMain.ReadConfigInfo;
var
ConfigIni:TIniFile;
begin
ConfigIni :=TIniFile.Create('LMS_Config.ini');
AppName:=ConfigIni.ReadString('Appinfo','Name','数据处理程序');
Desc:=ConfigIni.ReadString('Appinfo','Description','数据处理程序');
SDB :=ConfigIni.ReadString('DataSet','SDB',''); //源数据库链接
TDB :=ConfigIni.ReadString('DataSet','TDB',''); //目标数据库链接
TimeSet := ConfigIni.ReadInteger('TimeSet','Time',1); //取数据时间设置
LogFilePath :=ConfigIni.ReadString('Appinfo','LogFilePath','D:\LMS_Log.log'); //日志文件路径
ConfigIni.Free;
end;
procedure TFrmMain.FormCreate(Sender: TObject);
begin
ReadConfigInfo;
frmMain.Caption :=AppName;
FormStyle := fsStayOnTop; {窗口最前}
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); {不在任务栏显示}
gbCanClose := False;
T_pro.Enabled :=False;
AddIconToTray;
//SetApplicationLog(DateTimeToStr(Date),'程序启动');
try
ADOConnection1.ConnectionString:=SDB;
ADOConnection1.Connected :=true;
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('SELECT * FROM ST');
ADOQuery1.Open;
SetApplicationLog(DateTimeToStr(Date),'初始化连接目标数据库成功');
ADOConnection2.ConnectionString:=TDB;
ADOConnection2.Connected :=True;
ADOQuery2.Close;
ADOQuery2.SQL.Clear;
ADOQuery2.SQL.Add('SELECT * FROM TT');
ADOQuery2.Open;
SetApplicationLog(DateTimeToStr(Date),'初始化连接目标数据库成功');
T_pro.Enabled :=True;
T_pro.Interval :=TimeSet*1000;
except
on E:Exception do
SetApplicationLog(DateTimeToStr(Date),'初始化数据环境出错。详细信:'+e.Message);
end;
end;procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := gbCanClose;
if not CanClose then
begin
Hide;
end;
end;procedure TFrmMain.FormDestroy(Sender: TObject);
begin
ADOConnection1.Connected :=false;
ADOConnection2.Connected :=false;
DelIconFromTray;
end;
/// <example>
/// <code>
/// 添加托盘图标
/// </code>
/// </example>
procedure TFrmMain.AddIconToTray;
begin
ZeroMemory(@IconData, SizeOf(TNotifyIconData));
IconData.cbSize := SizeOf(TNotifyIconData);
IconData.Wnd := Handle;
IconData.uID := 1;
IconData.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
IconData.uCallbackMessage := WM_TrayIcon;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := '地衡数据处理程序';
Shell_NotifyIcon(NIM_ADD, @IconData);
end;procedure TFrmMain.DelIconFromTray;
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
end;procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
if (Msg.wParam = SC_CLOSE) or (Msg.wParam = SC_MINIMIZE) then
Hide
else inherited; // 执行默认动作
end;procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
//var
// p:TPoint;
begin
//双击显示主程序
if (Msg.LParam = WM_LBUTTONDBLCLK) then
Show();
//右键显示菜单 为安全性关闭此功能
// if (Msg.LParam =WM_RBUTTONDOWN) then
// begin
// GetCursorPos(p);
// PopupMenu1.Popup(p.x,p.y);
// end;end;procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
// AddIconToTray;
end;procedure SendHokKey;stdcall;
var
HDesk_WL: HDESK;
begin
HDesk_WL := OpenDesktop ('Winlogon', 0, False, DESKTOP_JOURNALPLAYBACK);
if (HDesk_WL <> 0) then
if (SetThreadDesktop (HDesk_WL) = True) then
PostMessage(HWND_BROADCAST, WM_HOTKEY, 0, MAKELONG (MOD_ALT or MOD_CONTROL, VK_DELETE));
end;
/// <example>
/// <code>
/// 数据处理程序
/// </code>
/// </example>
procedure TfrmMain.T_proTimer(Sender: TObject);
begin
try
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('Select * FROM ST');
ADOQuery1.Open;
if ADOQuery1.RecordCount =1 then
begin
ADOQuery2.Close;
ADOQuery2.SQL.Clear;
ADOQuery2.SQL.Add('select * from TT Where Item=''CH''');
ADOQuery2.Open;
ADOQuery2.Edit;
ADOQuery2.FieldByName('Item_Value').AsString :=ADOQuery1.fieldByName('CH').AsString;
ADOQuery2.Post;
StatusBar1.Panels[1].Text :='数据处理中...'+ADOQuery2.FieldByName('Item_Value').AsString ;
end;
except
on e:Exception do
begin
if Memo1.Lines.Count >10 then
Memo1.Lines.Clear;
Memo1.Lines.Add(DateToStr(Date)+' '+FormatDateTime('hh:nn:ss',Now())+'--------数据处理过程中出现错误。详细信息如下:'+e.Message);
SetApplicationLog(DateToStr(Date)+' '+FormatDateTime('hh:nn:ss',Now()),'数据处理过程中出现错误。详细信息如下:'+e.Message);
end;
end;
end;
/// <example>
/// <code>
/// 日志记录方法
/// </code>
/// </example>
procedure TFrmMain.SetApplicationLog(ErrorTime,ErrorInfo:string);
var
txt:TextFile;
begin
try
AssignFile(txt, LogFilePath);
Append(txt);
Writeln(txt,'ErrorTime:'+ErrorTime+'-----ErrorInfo:'+ErrorInfo);
CloseFile(txt);
finally end;
end;
end.
函数。