[DELPHI] Usługi systemowe w MS Windows 7

alien1983 · July 14, 2010

Ma ktoś jakiś przykładowy kod z" CreateProcesAsUser" dla delphi bo nie mogę go znalesc:/

Próbowałem przenieść kod z procesu na usługę systemową, niestety wystąpiło parę błędów o to kod:

 unit Unit1;

interface

uses
 Windows, Messages, SysUtils,Variants, Classes, Graphics, Controls, SvcMgr, Dialogs,
 ExtCtrls, Shellapi, IdBaseComponent, IdComponent, IdCustomHTTPServer, IdContext, IdHTTPServer,
 StdCtrls, ComCtrls, IdCustomTCPServer, IdSocketHandle, MMSystem, CPort, CPortCtl;

type
 TService1 = class(TService)
   Timer1: TTimer;


   procedure ServiceExecute(Sender: TService);
   procedure Timer1Timer(Sender: TObject);
   procedure ServiceCreate(Sender: TObject);


 private
   { Private declarations }
 public

   function GetServiceController: TServiceController; override;
   { Public declarations }
 protected

 end;

var
 Service1: TService1;
 IdHTTPServer1: TIdHTTPServer;
 ComPort1: TComPort;
 FHTMLDir: string;
 FTemplate: string;
 Timer2: TTimer;
 Handle:THandle;



 procedure IdHTTPServer1CommandGet(AContext: TIdContext;
 ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
 procedure StartHttpServer(Sender: TObject);
 procedure PGComPortComunication(z1:AnsiString; var z2:Real);

implementation

//uses Unit2;

{$R *.DFM}

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

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

procedure TService1.ServiceCreate(Sender: TObject);
begin
  FHTMLDir := ExtractFilePath(Application.GetNamePath) + 'HTML';

end;

procedure TService1.ServiceExecute(Sender: TService);
begin
 Timer1.Enabled := True;
 while not Terminated do
 ServiceThread.ProcessRequests(True);// wait for termination
 Timer1.Enabled := False;
end;

procedure IdHTTPServer1CommandGet(AContext: TIdContext;
 ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
 LFilename: string;
 LPathname: string;
 label skok_w_petli; //Funkcja skoku jeżeli Timer1 będzie false (powoduje czekanie aż do Timer1 = True)
begin
 LFilename := ARequestInfo.Document;
 if AnsiSameText(LFilename, '/elisia.htm') then begin
   //Ask(ARequestInfo, AResponseInfo);
 end else begin
   if LFilename = '/' then begin
     LFilename := '/index.htm';
   end;
   //Jeżeli chce index.htm to go generuje jeżeli nie chce to pomija tego if'a
   if LFilename = '/index.htm' then begin
   AResponseInfo.ContentText := ''
+ '<html>'
+ '<head>'
+ '<meta http-equiv="Refresh" content="10" />'
+ '</head>'
+ '<body>'
+ '    <h1><font face="Arial" size="3">AVATAR CONTROL SYSTEM (BETA1)</font></h1>'
+ '<table border="0" width="519">'
+ '     <tr>'
+ '             <td width="150">'
+ '             <p align="right"><b><font face="Arial" size="2">SERWER</font></b></td>'
+ '             <td width="7"></td>'
+ '             <td bgcolor="#00FF00" width="57">'
+ '             <p align="center"><b><font face="Arial" size="1">ONLINE</font></b></td>'
+ '             <td align="center" width="141"></td>'
+ '             <td align="center" width="142"></td>'
+ '     </tr>'
+ '     <tr>'
+ '             <td width="150">'
+ '             <p align="right"><b><font face="Arial" size="2">KLIENT 1</font></b></td>'
+ '             <td width="7"></td>'
+ '             <td bgcolor="#C0C0C0" width="57">'
+ '             <p align="center"><b><font face="Arial" size="1">OFFLINE</font></b></td>'
+ '             <td align="center" width="141"></td>'
+ '             <td align="center" width="142"></td>'
+ '     </tr>'
+ '     <tr>'
+ '             <td width="150">'
+ '             <p align="right"><b><font face="Arial" size="2">KLIENT 2</font></b></td>'
+ '             <td width="7"></td>'
+ '             <td bgcolor="#C0C0C0" width="57">'
+ '             <p align="center"><b><font face="Arial" size="1">OFFLINE</font></b></td>'
+ '             <td align="center" width="141"></td>'
+ '             <td align="center" width="142"></td>'
+ '     </tr>'
+ '     <tr>'
+ '             <td width="150">'
+ '             <p align="right"><b><font face="Arial" size="2">KLIENT 3</font></b></td>'
+ '             <td width="7"></td>'
+ '             <td bgcolor="#C0C0C0" width="57">'
+ '             <p align="center"><b><font face="Arial" size="1">OFFLINE</font></b></td>'
+ '             <td align="center" width="141"></td>'
+ '             <td align="center" width="142"></td>'
+ '     </tr>'
+ '     <tr>'
+ '             <td width="150">'
+ '             <p align="right"><b><font face="Arial" size="2">UPS PRIMARY</font></b></td>'
+ '             <td width="7"></td>';
 if Timer2.Enabled =true then
 begin
   AResponseInfo.ContentText := AResponseInfo.ContentText + '          <td bgcolor="#00FF00" width="57">'
   + '         <p align="center"><b><font face="Arial" size="1">ONLINE</font></b></td>'
 end
 else
 begin
   AResponseInfo.ContentText := AResponseInfo.ContentText + '          <td bgcolor="#C0C0C0" width="57">'
   + '         <p align="center"><b><font face="Arial" size="1">OFFLINE</font></b></td>'
 end;
AResponseInfo.ContentText := AResponseInfo.ContentText + '              <td align="center" width="141"></td>'
+ '             <td align="center" width="142"></td>'
+ '     </tr>'
+ '</table>'
+ '<table border="0" width="520">'
+ '     <tr>'
+ '<td width="150"><b><font face="Arial" size="2">UPS PRIMARY </font>'
+ '<font face="Arial" size="1">(POWER %)</font></b></td>'
+ '<td></td>'
+ '<td width="350">'
+ '<img border="0" src="bitmapa.bmp" width="350" height="50"></td>'
+ '</tr>'
+ '<tr>'
+ '<td width="150"></td>'
+ '<td></td>'
+ '<td width="350"></td>'
+ '</tr>'
+ '</table>'
+ '</body>'
+ '</html>';
   end;

   LPathname := FHTMLDir + LFilename;
   if FileExists(LPathname) then begin
     //AResponseInfo.ContentStream := TFileStream.Create(LPathname, fmOpenRead + fmShareDenyWrite);
     //Kod dla zapisu do pliku !
     skok_w_petli:
     if Timer2.Enabled = false then  //Pętla czekania na Timer dla wysyłania obrazka przez http
       begin
         Sleep(100);
         goto skok_w_petli;
       end;

     if Timer2.Enabled = true then
       begin
         try
           ///Richedit1.Lines.Add('OK');
           ///ms.Position := 0;
           ///Image1.Picture.Bitmap.LoadFromStream(ms);
           ///ms.Position := 0;
           AResponseInfo.ContentStream := TMemoryStream.Create();
           AResponseInfo.ContentStream.Position := 0;
           ///AResponseInfo.ContentStream.CopyFrom(ms, ms.Size);
         except
          //Komunikat błędów
         end;
       end;

   end else begin
     AResponseInfo.ResponseNo := 404;
     AResponseInfo.ContentText := 'The requested URL ' + ARequestInfo.Document
      + ' was not found on this server.';
   end;
 end;
end;


procedure StartHttpServer(Sender: TObject);
var
 //do uses dodać: idSocketHandle
 Binding : TIdSocketHandle;
begin
 //włączenie serwera
 if not IdHTTPServer1.Active then
 begin
   IdHTTPServer1.DefaultPort := 80;
   IdHTTPServer1.Bindings.Clear;
   Binding := IdHTTPServer1.Bindings.Add;
   Binding.Port := StrToIntDef(inttostr(IdHTTPServer1.DefaultPort), 80);
   Binding.IP := '192.168.0.25';
   try
     IdHTTPServer1.Active := true;
   except
     on e: exception do
     begin
       ShowMessage(format('Exception %s in Activate. Error is:"%s".', [e.ClassName, e.Message]));
     end;
   end;
 end;
 if IdHTTPServer1.Active then
 begin
   Showmessage('HTTP Serwer właczony!.' + #13 + 'Nasłuchiwanie na porcie: ' + inttostr(IdHTTPServer1.DefaultPort));
 end;
end;

procedure PGComPortComunication(z1:AnsiString; var z2:Real);
var
a : real;
b : string[5];
c : string;
begin
     b:='32,4';
     ComPort1.WriteStr(z1);//+CHR(13));  {Send modem Command}
     Sleep(5);
     ComPort1.ReadStr(z1,80);
     c:= copy(z1,0,1);
     if (c = '0') or (c = '1') then
     begin
       try
         ///b := AnsiReplaceStr(z1, '.', ','); //Zamiana znaku - przecinka na kropke
         //Delete(w,1,1);
         //RichEdit1.Lines.Add((S));
         //Trim(S);
         a :=  strtofloat(b);
       except
         a := 100.00;
       end;
         z2:= a;
         Delete(z1,6,2);
         ///RichEdit1.Lines.Add(z1);
         ///RichEdit1.Lines.Add©;
       end else begin
         ///RichEdit1.Lines.Add('Wystąpił znak:'+ z1);
       end;
end;


procedure TService1.Timer1Timer(Sender: TObject);
const
 FileName = 'c:\logdate.txt';
var
 F: TextFile;
 SI:TStartupInfo;
 PI:TProcessInformation;
begin
 Timer1.Enabled := false;


 //ShellExecute(Handle, nil, 'C:\Users\Serwis\Documents\RAD Studio\Projects\AVATAR HTTP CLIENT\Project1.exe', nil, nil, SW_SHOWNORMAL);

 //CreateProcess(nil,PChar('C:\Users\Serwis\Documents\RAD Studio\Projects\AVATAR HTTP CLIENT\Project1.exe'), nil,nil,FALSE,NORMAL_PRIORITY_CLASS,nil,nil,SI,PI);


 //WinExec('NazwaProga', SW_SHOW);
 {AssignFile(f,FileName);
 if FileExists(FileName) then Append(f)
 else
 Rewrite(f);
 writeln(f,DateTimeToStr(Now));
 //ShowMessage(DateTimeToStr(Now));
 CloseFile(f);  }
end;

end.ĘĄŚ)MQM(%!QQAMQ%!QQAM(
AQ
A(!Q51Ń(QąŃŃ(QQQ(!ąQ!ą((((%!QQAM
Ą
ŃQ%
Ń(IŃ%źQ%!QQAIŃ%źI%źQ%!QQAI%ź(MŃŃ!ŃŃMĄMQ=(A
AŃ
ŃĄMŃI(xĄĄŚŃ(QMąĄQM(QQQ(((MŃĄMQM(QQĄMQ=(M
ŃĄMQ=

bo w ogóle nie rozpocznie kompilacji, natomiast tak jak jest pod koniec kompilacji wywala błąd: "Project Project1.exe reised exception class EClassNo Found with message 'Class TComPort not found'"

Czy może ktoś miał do czynienia z podobnym problemem i wie jak go obejść ?

xevil21 · July 14, 2010

Posiadasz poprawnie zainstalowany komponent: ComPort?

Pozdrawiam!

alien1983 · July 14, 2010

Tak, działa jak tworze t wtrybie normalnej aplikacji, natomiast jak tworze usługe to nie działa czyli pokazuje sie to co opisałem , ogołnie chodzi o tą deklaracje Comport:Tcomport powina byc w types a nie w var niestety nie wiem jak poprawnie w trybie usługi je zdekalować.

Porzypomnę tylko że w trybie tworzenia aplikacji kod działa bezproblemu natomiast prpblem jest z przeniesieniem go to usługi. (tzn. delphi umozliwia stworzenie VCL Forms application jak i usług (service)) I chodzi mi oto (service). Bazuje na kodzie usługi która co sekunde zapisywała czas do pliku na dysku, wiec napewno usuge na moim delphi da się zrobić działającą.

Force · July 14, 2010

Skoro są błędy kompilacji to je podaj.

I wydaje mi się, że jak nie robi się okienko przez vcl to trzeba jakieś CoI.. (jakoś tam sie zwię) wywołać na początek samemu aby móc użyć com.

Sign In

[DELPHI] Usługi systemowe w MS Windows 7

Recommended Posts

alien1983

Link to comment

Share on other sites

xevil21

Link to comment

Share on other sites

alien1983

Link to comment

Share on other sites

Force

Link to comment

Share on other sites

Archived

Browse

Activity