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.
Tadeu Oliveira

Tadeu Oliveira

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?
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.


Responder

Assista grátis a nossa aula inaugural

Assitir aula

Saiba por que programar é uma questão de
sobrevivência e como aprender sem riscos

Assistir agora

Utilizamos cookies para fornecer uma melhor experiência para nossos usuários, consulte nossa política de privacidade.

Aceitar