Criação de Serviço do Windows com Delphi com Form rodando no Sys Tray
06/11/2009
0
Meus Caros.
Estou com o seguinte problema preciso urgentemente criar um serviço e que tenha um form para armazenar algumas configurações e que fique rodando minimizado na bandeja.
Já fiz de tudo e não consegui eu crio o serviço sem form e ele roda coloco o form ele não roda e meu prazo já venceu e faz tempo.
Quando tento instalar o seriço com a chamada ao form nem consigo instalar ele me da uma mensagem de erro 1057.
Solicito ajuda dos colegas.
Vou postar jundo um exemplo do que estou fazendo para que os colegas possam me ajudar com mais facilidade.
/===============================================================================/
CÓDIGO FONTE DO SERVIÇO
/===============================================================================/
unit Principal;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, Registry;
type
TsrvPrincipal = class(TService)
procedure ServiceExecute(Sender: TService);
procedure ServiceAfterInstall(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
{ Private declarations }
fServicePri : integer;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
srvPrincipal: TsrvPrincipal;
formRodando : Boolean;
implementation
uses fTeste;
{$R *.DFM}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
srvPrincipal.Controller(CtrlCode);
end;
function TsrvPrincipal.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TsrvPrincipal.ServiceExecute(Sender: TService);
begin
Application.CreateForm(TfrmTeste, frmTeste);
formRodando := frmTeste.ShowModal = mrOk;
{Loop enquanto estiver ativo}
while not Terminated do
begin
if not formRodando then
Self.Status := csStopped;
end;
end;
procedure TsrvPrincipal.ServiceAfterInstall(Sender: TService);
var
Descricao : TRegistry;
begin
try
Descricao := TRegistry.Create(KEY_READ or KEY_WRITE);
Descricao.RootKey := HKEY_LOCAL_MACHINE;
if (Descricao.OpenKey('\SYSTEM\CurrentControlSet\Services\' + Name, False)) then
begin
Descricao.WriteString('Description', 'Meu Serviço');
Descricao.CloseKey;
end
finally
FreeAndNil(Descricao)
end;
end;
procedure TsrvPrincipal.ServiceStart(Sender: TService;
var Started: Boolean);
begin
{Aqui definimos os valores padrão quando iniciado}
Started := False;
{Prioridade do Serviço}
fServicePri := NORMAL_PRIORITY_CLASS;
{Aqui determinamos a prioridade do serviço}
case fServicePri of
0 : SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
1 : SetPriorityClass(GetCurrentProcess, NORMAL_PRIORITY_CLASS);
2 : SetPriorityClass(GetCurrentProcess, HIGH_PRIORITY_CLASS);
3 : SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
end;
Started := True
end;
procedure TsrvPrincipal.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := True;
end;
end.
/===============================================================================/
CÓDIGO FONTE DO FORMULÁRIO
/===============================================================================/
unit fTeste;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellApi, Menus, StdCtrls, Buttons;
type
TfrmTeste = class(TForm)
PopupMenu1: TPopupMenu;
Restaurar: TMenuItem;
Fechar: TMenuItem;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RestaurarClick(Sender: TObject);
procedure FecharClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
protected procedure WndProc(var Msg: TMessage); override;
public
{ Public declarations }
TrayIconData: TNotifyIconData;
end;
var
frmTeste: TfrmTeste;
const
WM_ICONTRAY = WM_USER + 1;
implementation
uses Principal;
{$R *.dfm}
procedure TfrmTeste.FormCreate(Sender: TObject);
begin
with TrayIconData do
begin
cbSize := Sizeof(TrayIconData);
Wnd := Handle;
uID := 0;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
uCallbackMessage := WM_ICONTRAY;
hIcon := Application.Icon.Handle;
StrPCopy(SzTip, Application.Title);
end;
Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;
procedure TfrmTeste.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @TrayIconData);
end;
procedure TfrmTeste.WndProc(var Msg: TMessage);
var
p: TPoint;
begin
case Msg.Msg of WM_USER + 1:
case Msg.lParam of WM_RBUTTONDOWN:
begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopupMenu1.Popup(p.x,p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
WM_LBUTTONDBLCLK:
begin
Restaurar.Click;
end;
end;
end;
inherited;
end;
procedure TfrmTeste.RestaurarClick(Sender: TObject);
begin
frmTeste.Show;
ShowWindow(Application.Handle, SW_HIDE);
end;
procedure TfrmTeste.FecharClick(Sender: TObject);
begin
Application.ProcessMessages;
Application.Terminate;
end;
procedure TfrmTeste.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
frmTeste.Hide;
end;
procedure TfrmTeste.BitBtn1Click(Sender: TObject);
begin
Close;
end;
end.
Estou com o seguinte problema preciso urgentemente criar um serviço e que tenha um form para armazenar algumas configurações e que fique rodando minimizado na bandeja.
Já fiz de tudo e não consegui eu crio o serviço sem form e ele roda coloco o form ele não roda e meu prazo já venceu e faz tempo.
Quando tento instalar o seriço com a chamada ao form nem consigo instalar ele me da uma mensagem de erro 1057.
Solicito ajuda dos colegas.
Vou postar jundo um exemplo do que estou fazendo para que os colegas possam me ajudar com mais facilidade.
/===============================================================================/
CÓDIGO FONTE DO SERVIÇO
/===============================================================================/
unit Principal;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, Registry;
type
TsrvPrincipal = class(TService)
procedure ServiceExecute(Sender: TService);
procedure ServiceAfterInstall(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
{ Private declarations }
fServicePri : integer;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
srvPrincipal: TsrvPrincipal;
formRodando : Boolean;
implementation
uses fTeste;
{$R *.DFM}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
srvPrincipal.Controller(CtrlCode);
end;
function TsrvPrincipal.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TsrvPrincipal.ServiceExecute(Sender: TService);
begin
Application.CreateForm(TfrmTeste, frmTeste);
formRodando := frmTeste.ShowModal = mrOk;
{Loop enquanto estiver ativo}
while not Terminated do
begin
if not formRodando then
Self.Status := csStopped;
end;
end;
procedure TsrvPrincipal.ServiceAfterInstall(Sender: TService);
var
Descricao : TRegistry;
begin
try
Descricao := TRegistry.Create(KEY_READ or KEY_WRITE);
Descricao.RootKey := HKEY_LOCAL_MACHINE;
if (Descricao.OpenKey('\SYSTEM\CurrentControlSet\Services\' + Name, False)) then
begin
Descricao.WriteString('Description', 'Meu Serviço');
Descricao.CloseKey;
end
finally
FreeAndNil(Descricao)
end;
end;
procedure TsrvPrincipal.ServiceStart(Sender: TService;
var Started: Boolean);
begin
{Aqui definimos os valores padrão quando iniciado}
Started := False;
{Prioridade do Serviço}
fServicePri := NORMAL_PRIORITY_CLASS;
{Aqui determinamos a prioridade do serviço}
case fServicePri of
0 : SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
1 : SetPriorityClass(GetCurrentProcess, NORMAL_PRIORITY_CLASS);
2 : SetPriorityClass(GetCurrentProcess, HIGH_PRIORITY_CLASS);
3 : SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
end;
Started := True
end;
procedure TsrvPrincipal.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := True;
end;
end.
/===============================================================================/
CÓDIGO FONTE DO FORMULÁRIO
/===============================================================================/
unit fTeste;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellApi, Menus, StdCtrls, Buttons;
type
TfrmTeste = class(TForm)
PopupMenu1: TPopupMenu;
Restaurar: TMenuItem;
Fechar: TMenuItem;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RestaurarClick(Sender: TObject);
procedure FecharClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
protected procedure WndProc(var Msg: TMessage); override;
public
{ Public declarations }
TrayIconData: TNotifyIconData;
end;
var
frmTeste: TfrmTeste;
const
WM_ICONTRAY = WM_USER + 1;
implementation
uses Principal;
{$R *.dfm}
procedure TfrmTeste.FormCreate(Sender: TObject);
begin
with TrayIconData do
begin
cbSize := Sizeof(TrayIconData);
Wnd := Handle;
uID := 0;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
uCallbackMessage := WM_ICONTRAY;
hIcon := Application.Icon.Handle;
StrPCopy(SzTip, Application.Title);
end;
Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;
procedure TfrmTeste.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @TrayIconData);
end;
procedure TfrmTeste.WndProc(var Msg: TMessage);
var
p: TPoint;
begin
case Msg.Msg of WM_USER + 1:
case Msg.lParam of WM_RBUTTONDOWN:
begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopupMenu1.Popup(p.x,p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
WM_LBUTTONDBLCLK:
begin
Restaurar.Click;
end;
end;
end;
inherited;
end;
procedure TfrmTeste.RestaurarClick(Sender: TObject);
begin
frmTeste.Show;
ShowWindow(Application.Handle, SW_HIDE);
end;
procedure TfrmTeste.FecharClick(Sender: TObject);
begin
Application.ProcessMessages;
Application.Terminate;
end;
procedure TfrmTeste.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
frmTeste.Hide;
end;
procedure TfrmTeste.BitBtn1Click(Sender: TObject);
begin
Close;
end;
end.
Tadeu Oliveira
Curtir tópico
+ 0
Responder
Posts
07/11/2009
Pjrm1470
A mensagem de erro que aparece é esta?
ERROR_INVALID_SERVICE_ACCOUNT
1057 The account name is invalid or does not exist, or the password is invalid for the account name specified. Erro | Descrição Pelo que me lembro o Delphi ja vem com um componente TrayIcon. É muito bom se souber usa-lo. Qual Delphi está usando!? E ql sistema tá tentando instalar o serviço?
1057 The account name is invalid or does not exist, or the password is invalid for the account name specified. Erro | Descrição Pelo que me lembro o Delphi ja vem com um componente TrayIcon. É muito bom se souber usa-lo. Qual Delphi está usando!? E ql sistema tá tentando instalar o serviço?
Responder
07/11/2009
Tadeu Oliveira
Sim a mensagem é esta.
Estou utilizando o Delphi 7.
Estou tentando instalar este serviço no XP mas precisarei instalar em um servidor Windows Server 2003 ou superior e se possivel também nas demais versões do windows.
Estou utilizando o Delphi 7.
Estou tentando instalar este serviço no XP mas precisarei instalar em um servidor Windows Server 2003 ou superior e se possivel também nas demais versões do windows.
Responder
Clique aqui para fazer login e interagir na Comunidade :)