Vale, no se que es lo que he tocado, pero ahora funciona perfectamente en el modo debug de delphi. El problema da al ejecutarlo compilado como servicio, que no puede acceder a las carpetas de red, así que volvemos a la pregunta inicial. ¿Como le doy permisos al servicio para que pueda acceder a las carpetas de red? Os dejo todo el evento "OnExecute" para que le echéis un vistazo:
Código Delphi
[-]procedure TMYBackup.ServiceExecute(Sender: TService);
Resourcestring
error_1 = 'Out of memory/resources';
error_2 = 'GBAK not found';
error_3 = 'Path not found';
error_4 = 'Damaged or invalid exe';
error_5 = 'Access denied';
error_6 = 'Filename association invalid';
error_7 = 'DDE error';
error_8 = 'Sharing violation';
error_9 = 'Unknown error';
error_10= 'Destination directory not exists';
error_11= 'New Backup created';
error_12= 'Database retored';
var
Nombre : string;
proceed : boolean;
SEInfo : TShellExecuteInfo;
ExitCD : DWORD;
Actual_Time:Extended;
begin
while not terminated do begin
IBDataSet1.Refresh;
proceed:= false;
Actual_time:=now;
if IBDataSet1TYPE.asInteger = 0 then begin
if (Pos(IntToStr(DayOfTheWeek(Today)),IBDataSet1DAYS.AsString) <> 0 ) and (formatdatetime('hhnnss',IBDataSet1HOUR.value) = formatdatetime('hhnnss',Actual_time)) then begin
proceed := true;
end;
end
else if HoursBetween(Now,Old_Time) = IBDataSet1TIMELAPSE.AsInteger then begin
proceed := true;
Old_Time := Now;
end;
if (proceed) or (Backup_now) then begin
Nombre:= 'BACKUP - '+
StringOfChar('0',4-Length(IntToStr(YearOf(Now))))+IntToStr(YearOf(Now)) +
StringOfChar('0',2-Length(IntToStr(MonthOf(Now))))+IntToStr(MonthOf(Now)) +
StringOfChar('0',2-Length(IntToStr(DayOf(Now))))+IntToStr(DayOf(Now))+
StringOfChar('0',2-Length(IntToStr(HourOf(Now))))+IntToStr(HourOf(Now))+ '.FBK';
if IBDataSet1LOCAL_FTP.Value = 0 then begin
if not DirectoryExists( IBDataSet1LOCALDIR.AsString ) then begin
InsertError( 'NoDir', error_10 );
MYBackup.Status := csStopped;
Exit;
end;
if not FileExists(IBDataSet1LOCALDIR.AsString +'\'+ Nombre) then begin
try
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := 0;
lpFile := PWIDEChar(RegQueryStringValue('SOFTWARE\Firebird Project\Firebird Server\Instances', 'DefaultInstance')+'bin\gbak.exe');
nShow := SW_HIDE;
lpParameters := PWIDEChar('-v -t -user SYSDBA -password "masterkey" DATABASE ' + '"' + IBDataSet1LOCALDIR.AsString +'\'+ Nombre + '"');
end;
if ShellExecuteEx(@SEInfo) then begin
repeat
GetExitCodeProcess(SEInfo.hProcess, ExitCD);
until (ExitCD <> STILL_ACTIVE) or (Terminated);
end;
if (Backup_now) then UDPClient.Send('BACKUP_SUCCESS');
InsertError( 'New', error_11);
except
on e : Exception do begin
if GetLastError <= 32 then begin
case GetLastError of
0,se_err_OOM:
InsertError( 'OutMem', error_1 );
error_File_Not_Found:
InsertError( 'GMiss', error_2 );
error_Path_Not_Found:
InsertError( 'Path', error_3 );
error_Bad_Format:
InsertError( 'GBreak', error_4 );
se_err_AccessDenied:
InsertError( 'AccX', error_5);
se_err_NoAssoc,se_err_AssocIncomplete:
InsertError( 'BadFile', error_6);
se_err_DDEBusy,se_err_DDEFail,se_err_DDETimeOut:
InsertError( 'DDE', error_7 );
se_err_Share:
InsertError( 'Share', error_8);
else
InsertError( 'Unkn', error_9);
end;
MYBackup.Status := csStopped;
Exit;
end
else begin
InsertError( e.ClassName, e.Message );
MYBackup.Status := csStopped;
Exit;
end;
end;
end;
end;
end
else begin
if not FileExists(GetEnvironmentVariable('ProgramData') +'\PROGRAMA\'+ Nombre) then
try
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := 0;
lpFile := PWIDEChar(RegQueryStringValue('SOFTWARE\Firebird Project\Firebird Server\Instances', 'DefaultInstance')+'bin\gbak.exe');
nShow := SW_HIDE;
lpParameters := PWIDEChar('-v -t -user SYSDBA -password "masterkey" DATABASE ' + '"' + GetEnvironmentVariable('ProgramData') + '\PROGRAMA\' + Nombre + '"');
end;
if ShellExecuteEx(@SEInfo) then begin
repeat
GetExitCodeProcess(SEInfo.hProcess, ExitCD);
until (ExitCD <> STILL_ACTIVE) or (Terminated);
end;
except
on e : Exception do begin
if GetLastError <= 32 then begin
case GetLastError of
0,se_err_OOM:
InsertError( 'OutMem', error_1 );
error_File_Not_Found:
InsertError( 'GMiss', error_2 );
error_Path_Not_Found:
InsertError( 'Path', error_3 );
error_Bad_Format:
InsertError( 'GBreak', error_4 );
se_err_AccessDenied:
InsertError( 'AccX', error_5);
se_err_NoAssoc,se_err_AssocIncomplete:
InsertError( 'BadFile', error_6);
se_err_DDEBusy,se_err_DDEFail,se_err_DDETimeOut:
InsertError( 'DDE', error_7 );
se_err_Share:
InsertError( 'Share', error_8);
else
InsertError( 'Unkn', error_9);
end;
MYBackup.Status := csStopped;
Exit;
end
else begin
InsertError( e.ClassName, e.Message );
MYBackup.Status := csStopped;
Exit;
end;
end;
end;
with IdFTP1 do begin
try
Username := IBDataSet1FTPUSER.Value;
Password := IBDataSet1FTPPASS.Value;
Host := IBDataSet1FTPSERVER.Value;
Port := IBDataSet1FTPPORT.Value;
Connect;
SendCmd('MKD MYBackup');
SendCmd('CWD MYBackup');
Put(GetEnvironmentVariable('ProgramData') +'\PROGRAMA\'+ Nombre, Nombre);
if (Backup_now) then UDPClient.send('BACKUP_SUCCESS');
DeleteFile(GetEnvironmentVariable('ProgramData') +'\PROGRAMA\'+ Nombre);
InsertError( 'New', error_11);
Except
on e : Exception do begin
InsertError( e.ClassName, e.Message );
MYBackup.Status := csStopped;
Exit;
end;
end;
Disconnect;
end;
end;
Backup_now := false;
end;
if Restore then begin
Restore := false;
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := 0;
lpFile := PWIDEChar(RegQueryStringValue('SOFTWARE\Firebird Project\Firebird Server\Instances', 'DefaultInstance')+'bin\gbak.exe');
nShow := SW_HIDE;
lpParameters := PWIDEChar('-replace_database -v -user SYSDBA -password "masterkey" '+DirecciondelFBKtransmitidaporUDP+' DATABASE');
end;
try
if ShellExecuteEx(@SEInfo) then begin
repeat
GetExitCodeProcess(SEInfo.hProcess, ExitCD);
until (ExitCD <> STILL_ACTIVE) or (Terminated);
end;
if ExitCD = 1 then UDPClient.Send('RESTORE_FAIL')
else UDPClient.Send('RESTORE_FINISHED');
IBDatabase1.Connected := True;
InsertError( 'Res', error_12 );
except
on e : Exception do begin
if GetLastError <= 32 then begin
case GetLastError of
0,se_err_OOM:
InsertError( 'OutMem', error_1 );
error_File_Not_Found:
InsertError( 'GMiss', error_2);
error_Path_Not_Found:
InsertError( 'Path', error_3);
error_Bad_Format:
InsertError( 'GBreak', error_4 );
se_err_AccessDenied:
InsertError( 'AccX', error_5);
se_err_NoAssoc,se_err_AssocIncomplete:
InsertError( 'BadFile', error_6);
se_err_DDEBusy,se_err_DDEFail,se_err_DDETimeOut:
InsertError( 'DDE', error_7 );
se_err_Share:
InsertError( 'Share', error_8 );
else
InsertError( 'Unkn', error_9);
end;
MYBackup.Status := csStopped;
Exit;
end
else begin
InsertError( e.ClassName, e.Message );
MYBackup.Status := csStopped;
Exit;
end;
end;
end;
end;
sleep(1000);
ServiceThread.ProcessRequests(False);
end;
end;
Muchas gracias por todas las respuestas!
16-07-2013
Temas Similares
Modo Hilado