盒子论坛 v2.1

在winXP下可安装,运行的系统服务程序,在Win7下出错!

program ServiceDemo;

uses
  SvcMgr,
  Unit_Main in 'Unit_Main.pas' {DelphiService: TService},
  Unit_FrmMain in 'Unit_FrmMain.pas' {FrmMain};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TDelphiService, DelphiService);
  Application.CreateForm(TFrmMain, FrmMain);
  Application.Run;
end.

unit Unit_Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, Unit_FrmMain;

type
  TDelphiService = 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
  DelphiService: TDelphiService;
  FrmMain: TFrmMain;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  DelphiService.Controller(CtrlCode);
end;

function TDelphiService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TDelphiService.ServiceContinue(Sender: TService;
  var Continued: Boolean);
begin
  while not Terminated do
    begin
      Sleep(10);
      ServiceThread.ProcessRequests(False);
    end;
end;

procedure TDelphiService.ServiceExecute(Sender: TService);
begin
  while not Terminated do
    begin
      Sleep(10);
      ServiceThread.ProcessRequests(False);
    end;
end;

procedure TDelphiService.ServicePause(Sender: TService;
  var Paused: Boolean);
begin
  Paused := True;
end;

procedure TDelphiService.ServiceShutdown(Sender: TService);
begin
  gbCanClose := true;
  FrmMain.Free;
  Status := csStopped;
  ReportStatus();
end;

procedure TDelphiService.ServiceStart(Sender: TService;
  var Started: Boolean);
begin
  Started := True;
  Svcmgr.Application.CreateForm(TFrmMain, FrmMain);
  gbCanClose := False;
  FrmMain.Hide;
end;

procedure TDelphiService.ServiceStop(Sender: TService;
  var Stopped: Boolean);
begin
  Stopped := True;
  gbCanClose := True;
  FrmMain.Free;
end;

end.

unit Unit_FrmMain;

interface

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

const
WM_TrayIcon = WM_USER + 1234;

type
  TFrmMain = class(TForm)
    Timer1: TTimer;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(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;
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;
  gbCanClose: Boolean;

implementation

{$R *.DFM}

procedure TFrmMain.FormCreate(Sender: TObject);
begin
  FormStyle := fsStayOnTop; {窗口最前}
  SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); {不在任务栏显示}
  gbCanClose := False;
  Timer1.Interval := 1000;
  Timer1.Enabled := True;
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
  Timer1.Enabled := False;
  DelIconFromTray;
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 := 'Delphi服务演示程序';
  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);
begin
  if (Msg.LParam = WM_LBUTTONDBLCLK) then Show();
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;

procedure TFrmMain.Button1Click(Sender: TObject);
var
  dwThreadID : DWORD;
begin
  CreateThread(nil, 0, @SendHokKey, nil, 0, dwThreadID);
end;

end.

文本

----------------------------------------------
WKK

作者：

kkkmmm (KKKMMM)	★☆☆☆☆	-
	普通会员

2011/10/19 13:22:28

1楼：

楼主贴上一堆代码,但是又不是全部的源码,所以没办法测试.而且楼主也没有明确说明"出错"的具体描述.所以没办法具体指出应该修改哪里(没有仔细看过源码).

不过,单就有GUI的Winodws服务来讲,WinXP跟Vista/7下面的表现是不同的:在WinXP/2003下面工作正常,并且能显示GUI界面的服务,在Vista/7下面是无法正常显示界面的.原因是在新的服务框架下,服务程序是运行在Session0的,也就是无法以正常的方式显示GUI界面.

同时也可以在Win7下面发现一个新的系统服务叫做"Interactive Service Detection"(交互式服务检测),此服务用于"启用交互服务需要用户输入时进行用户通知，这样，便可以在交互服务创建的对话框出现时访问这些对话框。如果停止此服务，则对新交互服务对话框的通知将无法正常运行，而且可能无法访问这些交互服务对话框。如果已禁用此服务，则不再有新的交互服务对话框通知，也无法访问这些对话框。"

楼主代码中的OpenDesktop,SetWindowLong之类API调用都需要额外添加大量代码以获取到可操作对象后才可以进行,这跟开发普通桌面程序不同,这是因为普通桌面程序默认是运行在当前用户会话(Session)/当前桌面(Desktop)的.
----------------------------------------------
-

作者：

starrysea (星海)	▲▲▲▲▲	-
	普通会员

2011/10/19 19:19:12

2楼：

代码无法测试
----------------------------------------------
挂机赚钱 https://www.yiluzhuanqian.com/P3VpZD0zNjY0MA%3D%3D

作者：

soswkk (soswkk)	▲▲▲▲▲	-
	普通会员

2011/10/20 11:52:03

3楼：

首先感谢 kkkmmm ,现付上完整代码和出错截图,代码在WinXP下用Delphi5编译通过运行正常,在Win7下执行ServiceDemo.exe /Install时出现截图上的错误,请参详一下。

此帖子包含附件:soswkk_20111020115511.rar 大小:84.5K

----------------------------------------------
WKK

作者：

kkkmmm (KKKMMM)	★☆☆☆☆	-
	普通会员

2011/10/20 14:11:24

4楼：

@soswkk
使用XE2重新编译,程序能在Win7 Pro环境下使用-install参数自动安装服务,能由服务管理器"控制启动/停止,只是无法使看到程序界面.

我猜测应该是Delphi6的TService实现的-Install功能不能完全兼容WIN7操作系统.因为我手头没有Delphi6所以无法测试,楼主可以使用一些第三方的Windows服务管理软件进行手动安装,应该是没有问题的.

SrvMan:
官网网址: http://tools.sysprogs.org/srvman/
直接下载: http://tools.sysprogs.org/srvman/download/srvman-1.0.zip

运行SrvMan,然后点击"Add Service"按钮,在弹出的对话框中按照附件中的示范填写就可以了.另外,要显示GUI界面,这种方法已经在新版本的Windows中行不通了,要考虑其它变通方法,楼主可以Google一下"Windows Session0隔离".

此帖子包含附件:

大小:50.0K

----------------------------------------------
-

作者：

soswkk (soswkk)	▲▲▲▲▲	-
	普通会员

2011/10/27 7:18:53

5楼：

这几天我测试过,用XE2效果一样,应该是兼容性出问题,在Win7选容性WinXP SP3就可运行,这样就美中不足,如何改成真正Win7的服务程序。
----------------------------------------------
WKK

作者：

hsb_yq (hsb_yq)	★☆☆☆☆	-
	普通会员

2013/2/25 13:40:10

6楼：

老帖子了，我还是想说，应该是WIN7的管理员权限问题，CMD运行以管理员权限试试，我的就是那样解决的
----------------------------------------------
新手上路

信息

登陆以后才能回复