使用XE之后的開發工具，撰寫Service Application服務。
分別有如下視窗代碼：
1. 服務定義
unit uFileServer;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs, Main;
type
TZJGAFileServer = 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;
{ Public declarations }
end;
var
ZJGAFileServer: TZJGAFileServer;
FrmMain: TFrmMain;
implementation
{$R *.dfm}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
ZJGAFileServer.Controller(CtrlCode);
end;
function TZJGAFileServer.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TZJGAFileServer.ServiceContinue(Sender: TService;
var Continued: Boolean);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;
procedure TZJGAFileServer.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;
procedure TZJGAFileServer.ServicePause(Sender: TService; var Paused: Boolean);
begin
Paused := True;
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' ServicePause End.');
end;
procedure TZJGAFileServer.ServiceShutdown(Sender: TService);
begin
g_gbCanClose := True;
FrmMain.Free;
Status := csStopped;
ReportStatus();
end;
procedure TZJGAFileServer.ServiceStart(Sender: TService; var Started: Boolean);
begin
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' ServiceStart End.');
Started := True;
Vcl.Svcmgr.Application.CreateForm(TFrmMain, FrmMain);
g_gbCanClose := False;
FrmMain.Hide;
end;
procedure TZJGAFileServer.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' ServiceStop End.');
Stopped := True;
g_gbCanClose := True;
FrmMain.Free;
end;
end.
2. 服務彈窗
unit Main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, ShellApi, Vcl.StdCtrls;
const
WM_TrayIcon = WM_USER + 1234;
type
TFrmMain = class(TForm)
Timer1: TTimer;
Button1: TButton;
TrayIcon1: TTrayIcon;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure TrayIcon1DblClick(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;
public
{ Public declarations }
end;
var
FrmMain: TFrmMain;
g_gbCanClose: Boolean;
g_FileNum: Integer;
//撰寫臨時日志
procedure WriteLog(Log: String);
implementation
{$R *.dfm}
//撰寫臨時日志
procedure WriteLog(Log: String);
var WriteFile: TextFile; SQLFileFullName: String;
begin
//生成檔案
SQLFileFullName := 'D:\UpFile\Log\test'+FormatFloat('0000',g_FileNum)+'.log';
AssignFile(WriteFile, SQLFileFullName);
ReWrite(WriteFile);
try
WriteLn(WriteFile, Log);
finally
CloseFile(WriteFile);
end;
Inc(g_FileNum);
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;
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.Button1Click(Sender: TObject);
var
dwThreadID : DWORD;
begin
CreateThread(nil, 0, @SendHokKey, nil, 0, dwThreadID);
end;
procedure TFrmMain.DelIconFromTray;
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
end;
procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := g_gbCanClose;
if not CanClose then
begin
Hide;
end;
end;
procedure TFrmMain.FormCreate(Sender: TObject);
begin
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' Main FormCreate Begin.');
TrayIcon1.Hint := Application.Title;
FormStyle := fsStayOnTop; {視窗最前}
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); {不在任務欄顯示}
g_gbCanClose := False;
Timer1.Interval := 1000;
Timer1.Enabled := True;
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' Main FormCreate End.');
end;
procedure TFrmMain.FormDestroy(Sender: TObject);
begin
Timer1.Enabled := False;
DelIconFromTray;
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.Timer1Timer(Sender: TObject);
begin
//Timer1.Enabled := False;
//AddIconToTray;
TrayIcon1.Visible := True;
end;
procedure TFrmMain.TrayIcon1DblClick(Sender: TObject);
begin
Show();
end;
procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
begin
if (Msg.LParam = WM_LBUTTONDBLCLK) then
Show();
end;
end.
3. 工程代碼
program TestLog;
uses
Vcl.SvcMgr, //Vcl.Forms, System.SysUtils,
uFileServer in 'uFileServer.pas' {ZJGAFileServer: TService},
Main in 'Main.pas' {FrmMain};
{$R *.RES}
begin
g_FileNum := 1;
Application.Initialize;
Application.CreateForm(TZJGAFileServer, ZJGAFileServer);
Application.Run;
end.
服務是可以正常啟動、停止、暫停。但是服務啟動之后，沒有添加右下角任務圖示，并且寫了WriteLog日志也沒有執行！
請教各位，這個是何情況？
uj5u.com熱心網友回復：
定義：constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
如下：
constructor TZJGAFileServer.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
inherited CreateNew(AOwner, Dummy);
AllowPause := False;
Interactive := True;
OnStart := ServiceStart;
OnStop := ServiceStop;
OnPause := ServicePause;
end;
沒觸發原因導致.
uj5u.com熱心網友回復：
但是 圖示為何暫時無法做解答，可能是該模式下圖示加載失敗。如果是直接exe，TrayIcon1.Visible := True;就能顯示。uj5u.com熱心網友回復：
加個Timer。定時啟動托盤,隱藏界面。uj5u.com熱心網友回復：
謝謝，托盤的我加了timer和隱藏頁面，但是一直無用的。代碼前面已有，我再拷貝出來，如下：procedure TZJGAFileServer.ServiceStart(Sender: TService; var Started: Boolean);
begin
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' ServiceStart End.');
Started := True;
Application.CreateForm(TFrmMain, FrmMain);
g_gbCanClose := False;
FrmMain.Hide;
end;
procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' TrayIcon Visible.');
Timer1.Enabled := False;
TrayIcon1.Visible := True;
end;
uj5u.com熱心網友回復：
有個奇怪的，想咨詢下，是否跟這個有關：ServiceStart 下，我添加如下代碼：
WriteLog(FormatDateTime('YYYY-MM-DD HH:MM:SS', Now)+' ServiceStart End.');
Started := True;
Application.CreateForm(TFrmMain, FrmMain);
FrmMain.Show;
g_gbCanClose := False;
視窗不會顯示？
uj5u.com熱心網友回復：
是否是如下情況：在Vista和Windows7以上服務是運行在不同的會話中,不能在用戶的會話顯示界面,完全隔離了.
只能是在用戶會話運行帶界面的程式,和服務程式進行行程通訊來控制.
uj5u.com熱心網友回復：
有這種可能，但不會一點反應都沒有。
uj5u.com熱心網友回復：
我是寫日志監測是否執行完畢的，代碼是執行了，就是不彈窗。
FrmMain也創建了，創建的時候，自動加載右下角TrayIcon圖示，也沒有顯示出來，代碼也是執行了。
所以很奇怪
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/55142.html
標籤：VCL組件開發及應用