Mega Code Archive
Shutdown, to restart, to close session from the PC to a certain hour
<![CDATA[
Title: Shutdown, to restart, to close session from the PC to a certain hour
Question: How to shutdown, to restart, to close session from the PC to a certain hour (it works in Windows 2000/XP)
Answer:
Source code to shutdown, restart, to close session of the PC or to show a warning at a specified hour:
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShellApi, Menus, ExtCtrls, ActnList, StdCtrls, ComCtrls, Buttons;
type
TwndIconic = class(TForm)
GroupBox1: TGroupBox;
lHoraActual: TLabel;
RadioGroup1: TRadioGroup;
gAccion: TGroupBox;
lHora: TLabel;
Button3: TButton;
BMinimizar: TButton;
BAjustar: TButton;
Button2: TButton;
actAction: TActionList;
actAcercaDe: TAction;
actAyuda: TAction;
actAjustarHora: TAction;
actMinimizar: TAction;
actSalir: TAction;
Temporizador: TTimer;
PopupMenu1: TPopupMenu;
Acercade1: TMenuItem;
Ayuda1: TMenuItem;
Ajustarhora1: TMenuItem;
Minimizar1: TMenuItem;
Salir1: TMenuItem;
opApagar: TRadioButton;
opReiniciar: TRadioButton;
opReiniciarEquipo: TRadioButton;
opAviso: TRadioButton;
BE: TStatusBar;
actConfiguracion: TAction;
N1: TMenuItem;
Configuracin1: TMenuItem;
N2: TMenuItem;
LWEB: TLabel;
Nuev: TLabel;
GroupBox2: TGroupBox;
opGuardar: TCheckBox;
opCapturar: TCheckBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure actAcercaDeExecute(Sender: TObject);
procedure actAjustarHoraExecute(Sender: TObject);
procedure actMinimizarExecute(Sender: TObject);
procedure actSalirExecute(Sender: TObject);
procedure TemporizadorTimer(Sender: TObject);
procedure opApagarClick(Sender: TObject);
procedure opApagarDblClick(Sender: TObject);
procedure opAvisoClick(Sender: TObject);
procedure opReiniciarClick(Sender: TObject);
procedure opReiniciarDblClick(Sender: TObject);
procedure opReiniciarEquipoClick(Sender: TObject);
procedure opReiniciarEquipoDblClick(Sender: TObject);
procedure actConfiguracionExecute(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure RealizarProceso ();
procedure LWEBClick2(Sender: TObject);
private
iconificada : boolean;
FTrayMessage: Cardinal;
ejecutadoYa : boolean;
procedure RButtonUp;
procedure LButtonDblClk;
protected
procedure WndProc(var Msg: TMessage); override;
public
Hora : TDatetime;{ Public declarations }
cancelar, realizar : boolean;
procedure NotifyTray(Command: Word; const Hint: string);
end;
var
wndIconic: TwndIconic;
implementation
uses About, unidadajustarhora, unidadRealizar;
{$R *.DFM}
resourcestring
STrayMessage = 'AjpdSoft PCU 1.0';
procedure TwndIconic.NotifyTray(Command: Word; const Hint: string);
var
Data: TNotifyIconData;
begin
Data.cbSize := SizeOf(Data);
Data.uID := 0;
Data.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
Data.Wnd := Self.Handle;
Data.uCallbackMessage := FTrayMessage;
Data.hIcon := Application.Icon.Handle;
StrLCopy(Data.szTip, PChar(Hint), SizeOf(Data.szTip));
Shell_NotifyIcon(Command, @Data);
end;
procedure TwndIconic.WndProc(var Msg: TMessage);
begin
if Msg.Msg = FTrayMessage then
case Msg.LParam of
WM_RBUTTONUP: RButtonUp;
WM_LBUTTONDBLCLK: LButtonDblClk;
end
else
inherited WndProc(Msg);
end;
procedure TwndIconic.LButtonDblClk;
begin
with Twndabout.Create(nil) do
try
ShowModal;
finally
Free;
end;
end;
procedure TwndIconic.RButtonUp;
var
Pt: TPoint;
begin
GetCursorPos(Pt);
SetForegroundWindow(Application.Handle);
Application.ProcessMessages;
PopupMenu1.Popup(Pt.X, Pt.Y);
end;
procedure TwndIconic.FormCreate(Sender: TObject);
begin
realizar := False;
cancelar := False;
iconificada := false;
lhoraactual.Caption := TimeToStr (time);
end;
procedure TwndIconic.FormDestroy(Sender: TObject);
begin
ejecutadoya := false;
NotifyTray(NIM_DELETE, '');
end;
procedure TwndIconic.actAcercaDeExecute(Sender: TObject);
begin
with Twndabout.Create(nil) do
try
ShowModal;
finally
Free;
end;
end;
procedure TwndIconic.actAjustarHoraExecute(Sender: TObject);
begin
If frmAjustarHora.ShowModal = MrOk Then
begin
try
begin
Hora := StrToTime(frmAjustarHora.txthora.Text);
lhora.Caption := frmAjustarHora.txthora.Text;
actAjustarHora.caption := 'Change hour';
if opApagar.Checked then
caption := 'Shutdown at the: ' + TimeToStr (hora);
if opReiniciar.Checked then
caption := 'Restart at the: ' + TimeToStr (hora);
if opAviso.Checked then
caption := 'Warning at the: ' + TimeToStr (hora);
ejecutadoya := false;
temporizador.Enabled := true;
end;
except
messagedlg ('The introduced hour is not correct.', mterror, [mbok],0);
end;
end;
end;
procedure TwndIconic.actMinimizarExecute(Sender: TObject);
begin
hide;
actMinimizar.visible := false;
actConfiguracion.visible := true;
Application.ShowMainForm := False;
ShowWindow(Application.Handle, SW_HIDE);
FTrayMessage := RegisterWindowMessage(PChar(STrayMessage));
NotifyTray(NIM_ADD, '');
iconificada := true;
end;
procedure TwndIconic.actSalirExecute(Sender: TObject);
begin
close;
end;
function GetErrorstring: string;
var
lz : Cardinal;
err : array[0..512] of Char;
begin
lz := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
Result := string(err);
end;
procedure apagarPC;
var
rl, flgs : Cardinal;
hToken : Cardinal;
tkp : TOKEN_PRIVILEGES;
begin
flgs := 0;
flgs := flgs or EWX_POWEROFF;
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, hToken) then
ShowMessage ('Has not been possible to open the process. [' + GetErrorstring + ']')
else
begin
if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
begin
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
tkp.PrivilegeCount := 1;
AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
if GetLastError ERROR_SUCCESS then
ShowMessage('An error has taken place when trying to adjust the privileges.');
end
else
ShowMessage('Has not been the value of the privilege. [' + GetErrorstring + ']');
end;
ExitWindowsEx(flgs, 0);
end;
end;
procedure TwndIconic.RealizarProceso ();
begin
//shutdown
If (opapagar.checked = True) Then
begin
apagarPC;
end;
//close session current user
If (opreiniciar.checked = True) Then
ExitWindowsEx (0,0);
//restart PC
If (opReiniciarEquipo.checked = True) Then
ExitWindowsEx (EWX_REBOOT,0);
//Warning
If (opaviso.checked = True) Then
messagedlg ('I warn of the program PCU, surely have something to make...',
mtwarning, [mbok],0);
frmRealizando.hacer := false;
frmRealizando.Close;
end;
procedure TwndIconic.TemporizadorTimer(Sender: TObject);
Var
hAlarma,mAlarma : word;
hActual,mActual : word;
Milisegundos, Segundos : word;
begin
lhoraactual.Caption := TimeToStr (time);
if not ejecutadoYa then
begin
DecodeTime(Hora, hAlarma, mAlarma, segundos, Milisegundos);
DecodeTime(Time, hActual, mActual, segundos, Milisegundos);
if iconificada then
begin
if lhora.Caption 'Without adjusting hour...' then
begin
if opapagar.Checked then
if iconificada then
NotifyTray(NIM_MODIFY, 'The PC will fade to those: ' + lHora.Caption);
if opReiniciar.Checked then
if iconificada then
NotifyTray(NIM_MODIFY, 'The session will close to those: ' + lHora.Caption);
if opReiniciarEquipo.Checked then
if iconificada then
NotifyTray(NIM_MODIFY, 'The PC will be restarted to those: ' + lHora.Caption);
if opAviso.Checked then
if iconificada then
NotifyTray(NIM_MODIFY, 'The PC will warn to those: ' + lHora.Caption);
end
else
NotifyTray(NIM_MODIFY, 'It has not adjusted hour of action');
end;
//shutdown
If (HActual = hAlarma) and (mActual= mAlarma) and
(opapagar.checked = True) Then
Begin
ejecutadoya := true;
frmrealizando.lAccion.Caption := 'Will shutdown the PC...';
frmrealizando.temporizador.Enabled := true;
frmrealizando.show;
end;
//Close the current session
If (HActual = hAlarma) and (mActual= mAlarma) and
(opreiniciar.checked = True) Then
begin
ejecutadoya := true;
frmrealizando.lAccion.Caption := 'Closing the current session...';
frmrealizando.temporizador.Enabled := true;
frmrealizando.show;
end;
//Restart the PC
If (HActual = hAlarma) and (mActual= mAlarma) and
(opReiniciarEquipo.checked = True) Then
begin
ejecutadoya := true;
frmrealizando.lAccion.Caption := 'Restarting the PC...';
frmrealizando.temporizador.Enabled := true;
frmrealizando.show;
end;
//warning
If (HActual = hAlarma) and (mActual= mAlarma) and
(opaviso.checked = True) Then
begin
ejecutadoya := true;
temporizador.Enabled := false;
frmrealizando.lAccion.Caption := 'Warning to the user...';
frmrealizando.temporizador.Enabled := true;
frmrealizando.show;
end;
end;
end;
procedure TwndIconic.opApagarClick(Sender: TObject);
begin
ejecutadoya := false;
be.Panels[0].Text := 'Action: TURN OFF';
end;
procedure TwndIconic.opApagarDblClick(Sender: TObject);
begin
ExitWindowsEx (1,0);
end;
procedure TwndIconic.opAvisoClick(Sender: TObject);
begin
ejecutadoya := false;
be.Panels[0].Text := 'Action: I WARN';
end;
procedure TwndIconic.opReiniciarClick(Sender: TObject);
begin
ejecutadoya := false;
be.Panels[0].Text := 'Action: RESTART CURRENT SESSION';
end;
procedure TwndIconic.opReiniciarDblClick(Sender: TObject);
begin
ExitWindowsEx (0,0);
end;
procedure TwndIconic.opReiniciarEquipoClick(Sender: TObject);
begin
ejecutadoya := false;
be.Panels[0].Text := 'Action: RESTART PC';
end;
procedure TwndIconic.opReiniciarEquipoDblClick(Sender: TObject);
begin
ExitWindowsEx (EWX_REBOOT,0);
end;
procedure TwndIconic.actConfiguracionExecute(Sender: TObject);
begin
show;
actMinimizar.Visible := true;
iconificada := false;
end;
procedure TwndIconic.LWEBClick2(Sender: TObject);
begin
ShellExecute(Handle, Nil, PChar(LWEB.CAPTION),
Nil, Nil, SW_SHOWNORMAL);
end;
end.
*******************************************
unit unidadajustarhora;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Mask, Buttons, ExtCtrls;
type
TfrmAjustarHora = class(TForm)
txtHora: TMaskEdit;
Label1: TLabel;
BitBtn1: TBitBtn;
Panel1: TPanel;
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmAjustarHora: TfrmAjustarHora;
implementation
{$R *.DFM}
end.
********************************************************++
unit unidadRealizar;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls;
type
TfrmRealizando = class(TForm)
bp: TProgressBar;
lAccion: TLabel;
Button1: TButton;
Button2: TButton;
temporizador: TTimer;
procedure FormShow(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure temporizadorTimer(Sender: TObject);
private
bpulsado : boolean;
{ Private declarations }
public
hacer : boolean;
{ Public declarations }
end;
var
frmRealizando: TfrmRealizando;
implementation
uses Main;
{$R *.dfm}
procedure TfrmRealizando.FormShow(Sender: TObject);
begin
hacer := true;
bpulsado := false;
end;
procedure TfrmRealizando.Button2Click(Sender: TObject);
begin
bpulsado := true;
wndiconic.cancelar := true;
wndiconic.realizar := false;
close;
end;
procedure TfrmRealizando.Button1Click(Sender: TObject);
begin
bpulsado := true;
wndiconic.realizar := true;
wndiconic.cancelar := false;
close;
end;
procedure TfrmRealizando.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
if hacer then
begin
if not bpulsado then
wndIconic.realizar := true;
wndiconic.realizarProceso();
end;
end;
procedure TfrmRealizando.temporizadorTimer(Sender: TObject);
var
i, j, k : integer;
begin
temporizador.Enabled := false;
wndiconic.cancelar := false;
wndiconic.realizar := false;
bpulsado := false;
bp.Min := 0;
bp.max := 1000;
bp.Position := 0;
refresh;
for i := 0 to 1000 do
begin
bp.Position := i;
Application.ProcessMessages;
if (wndiconic.cancelar) or (wndiconic.realizar) then
begin
bpulsado := true;
close;
end;
for j := 1 to 1000 do
for k := 1 to 1000 do
end;
close;
end;
end.
************************************************************
unit About;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, shellapi;
type
Twndabout = class(TForm)
Label1: TLabel;
Label2: TLabel;
Bevel1: TBevel;
Label3: TLabel;
Label4: TLabel;
txMemory: TLabel;
txFree: TLabel;
Button1: TButton;
LWEB: TLabel;
procedure FormCreate(Sender: TObject);
procedure LWEBClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
wndabout: Twndabout;
implementation
{$R *.DFM}
procedure Twndabout.FormCreate(Sender: TObject);
var
MS: TMemoryStatus;
begin
MS.dwLength := SizeOf(MS);
GlobalMemoryStatus(MS);
txMemory.Caption := FormatFloat('#, KB', MS.dwTotalPhys div 1024);
txFree.Caption := FormatFloat('#, KB', MS.dwAvailPhys div 1024);
end;
procedure Twndabout.LWEBClick(Sender: TObject);
begin
ShellExecute(Handle, Nil, PChar(LWEB.CAPTION),
Nil, Nil, SW_SHOWNORMAL);
end;
end.
]]>