home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
StartRight
/
source.zip
/
UnitFrmDummyRunner.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2004-10-08
|
12KB
|
438 lines
unit UnitFrmDummyRunner;
{
Purpose:
This form controls the startup process by creating/removing
the system tray icon and running the behind the sense processes.
Updates:
New Status/Pause/Stop dialog option
--------------
Icon notification for new items and double click will open the Edit
form and hilight new itesm
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellAPI, UnitMyRegistry,
UnitStartupMover, UnitStartupRunner, ImgList, StdCtrls, ExtCtrls;
const MY_WM_TRAYICON = WM_USER + 1; // used to receive tray icon messsages
type
TfrmDummyRunner = class(TForm)
ImageList1: TImageList;
bPause: TButton;
bStop: TButton;
Image2: TImage;
Memo1: TMemo;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure bStopClick(Sender: TObject);
procedure bPauseClick(Sender: TObject);
private
{ Private declarations }
messagelog : string;
sm : TStartupMover;
sr : TStartupRunner;
paused : boolean;
TrayIcon: TNotifyIconData; {tray icon info}
procedure WMTrayIcon(var Msg: TMessage); message MY_WM_TRAYICON;
procedure ShowIcon;
procedure NewItemsIcon;
//procedure DoMoveAndRun;
procedure DoRunOnceMoving;
procedure PostRunOnceExecute;
procedure FlagRunOnceExecuted;
procedure ClearRunOnceExecutedFlag;
//function HasRunOnce : boolean;
function IsPaused : boolean;
public
{ Public declarations }
procedure HideIcon;
procedure Callback_ShowMessage(name : string);
end;
var
frmDummyRunner: TfrmDummyRunner;
{\\\\\\\\\\\\\\\\\\\\}
{\\}implementation{\\}
{\\\\\\\\\\\\\\\\\\\\}
Uses UnitFormEdit, UnitItemManager, UnitFrmOptions, UnitMyKeys, UnitUtils, StrUtils,
UnitCPUUsage, UnitFrmAutoTuneError;
{$R *.dfm}
//-------------------
// Public Interface
//-------------------
procedure TfrmDummyRunner.Callback_ShowMessage(name: string);
begin
self.messagelog := self.messagelog + #13#10 + name;
self.memo1.text := name;
Application.ProcessMessages;
end;
//-----------------------
// Private Implementation
//-----------------------
procedure TfrmDummyRunner.FormCreate(Sender: TObject);
procedure ShowStatusDialog;
begin
Windows.SetWindowPos(application.handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE Or SWP_NOSIZE);
self.Show;
end;
var s : string;
begin
sm := TStartupMover.Create(self.Handle);
sr := TStartupRunner.Create(self.Handle);
//
// -pre = RunOnce key that is run before explorer is executed
// -go = Test if "-pre" was executed and execute either new or old method
// This will be backwards compatible for systems that fail to execute
// the RunOnce method or systems that have not yet this updated code.
//
if (ParamCount <> 0) then begin
s := paramstr(1);
if (s = '-pre') then begin
if (not FrmOptions.cbDisableMoveDialog.Checked) then ShowStatusDialog;
if (sm.UserHasPermission(s)) then begin
sm.SetupSelfToRun(false); while self.IsPaused do mysleep(50);
self.DoRunOnceMoving; while self.IsPaused do mysleep(50);
self.FlagRunOnceExecuted; while self.IsPaused do mysleep(50);
end else begin
self.Callback_ShowMessage(
'ERROR: Permission Denied on :' + #13#10 + s
);
mysleep(4000);
end;
// ensure the RUN key has the "-go" runkey set up
while self.IsPaused do mysleep(50);
Application.Terminate;
end else if (s = '-go') then begin
// set up only RunOnce key
// make sure Run key is removed - just to be safe
self.Callback_ShowMessage('Starting...');
if (sm.UserHasPermission(s)) then begin
sm.SetupSelfToRunOnce;
sm.RemoveSelfFromRun(false);
if (FrmOptions.cbShowStartupDialog.Checked) then ShowStatusDialog;
self.PostRunOnceExecute;
self.ClearRunOnceExecutedFlag;
UnitMyKeys.SaveLowHighCPUStats;
if (sm.GetHasNewItemsAndClear) and
not (FrmOptions.cbDisableSysTrayNotification.Checked) then begin
self.NewItemsIcon;
end else begin
Application.Terminate;
end;
end else begin
ShowStatusDialog;
self.Callback_ShowMessage(
'ERROR: Permission Denied on :' + #13#10 + s
);
mysleep(4000);
Application.Terminate;
end;
end;
end;
end;
procedure TfrmDummyRunner.FormDestroy(Sender: TObject);
begin
sm.Free;
sr.Free;
end;
{Phase 1 of Execution}
procedure TfrmDummyRunner.DoRunOnceMoving;
var i : integer;
s : string;
rki : TRunKeyItem;
sfi : TStartupFolderItem;
begin
//
// -- RunOnce key policy states we must continue with NO user input
// Display Progess and if any items were found
//
try
self.Callback_ShowMessage('Detecting New items.');
s := '';
for i := 0 to (sm.GetRunkeyItemsCount - 1) do begin
rki := sm.GetRunkeyItem(i);
if not UnitMyKeys.GetIsExcludedRunkey(rki.RunKey) then begin
s := s + 'Runkey: ' + rki.RunKey + #13#10;
end;
end;
for i := 0 to (sm.GetStartupFolderItemsCount - 1) do begin
sfi := sm.GetStartupFolderItem(i);
if not UnitMyKeys.GetIsExcludedStartup(ExtractFilename(sfi.fullname)) then begin
s := s + 'Startup: ' + ExtractFilename(sfi.fullname);
end;
end;
if (s <> '') then begin
self.Callback_ShowMessage('Items Found.' + #13#10 + s);
mysleep(1500);
end else begin
Self.Callback_ShowMessage('No new items.');
mysleep(1500);
end;
sm.MoveRunKeyItems;
sm.MoveStartupFolderItems;
Except on E: Exception do
begin
self.Callback_ShowMessage('ERROR: ' + E.Message );
mysleep(4000);
Application.Terminate;
end;
end;
end;
{Phase 2 of Execution}
procedure TfrmDummyRunner.PostRunOnceExecute;
var cpu : string;
begin
self.ShowIcon;
if (FrmOptions.cbShowStartupDialog.Checked) then begin
self.Show;
end;
if (FrmOptions.cbDisableAutoTune.checked = false) then begin
cpu := IntToStr(trunc(UnitCPUUsage.GetCPUUsage));
end;
self.Callback_ShowMessage('(Pausing ' +
IntToStr(sr.GetPrerunDelaySeconds) +
' seconds before executing)'
+#13#10'CPU% ' + cpu);
Application.ProcessMessages;
FrmAutoTuneError.CheckForError;
sr.ExecutePrerunDelay;
sr.ExecuteRunkeyPrograms;
sr.ExecuteStartupFolderPrograms;
self.Hide;
self.HideIcon;
end;
{Tray Icon routines}
procedure TfrmDummyRunner.ShowIcon;
begin
//
// Create System Tray Icon
//
TrayIcon.cbSize := SizeOf(TrayIcon);
TrayIcon.Wnd := Self.Handle;
TrayIcon.uID := 0;
TrayIcon.uFlags := NIF_ICON or NIF_TIP or NIF_MESSAGE;
TrayIcon.uCallbackMessage := 0;
TrayIcon.hIcon := Application.Icon.Handle;
TrayIcon.szTip := 'StartRight';
ShellAPI.Shell_notifyIcon(NIM_ADD, @TrayIcon);
end;
procedure TfrmDummyRunner.HideIcon;
begin
//
// Remove tray icon
//
ShellAPI.Shell_notifyIcon(NIM_DELETE, @TrayIcon);
end;
procedure TFrmDummyRunner.WMTrayIcon(var Msg: TMessage);
begin
//
// show the edit form and hilight the new items
//
if (Msg.lparam = WM_LBUTTONDBLCLK) or
(Msg.lparam = WM_LBUTTONDBLCLK) then begin
//ShellAPI.Shell_notifyIcon(NIM_DELETE, @TrayIcon);
FrmEdit.SetEndProgramOnClose(true);
FrmEdit.ShowNewItems;
end;
end;
procedure TfrmDummyRunner.NewItemsIcon;
var icon : TIcon;
begin
icon := TIcon.Create;
ImageList1.GetIcon(1, icon);
TrayIcon.cbSize := SizeOf(TrayIcon);
TrayIcon.Wnd := Self.Handle;
TrayIcon.uID := 0;
TrayIcon.uFlags := NIF_ICON or NIF_TIP or NIF_MESSAGE;
TrayIcon.uCallbackMessage := MY_WM_TRAYICON;
TrayIcon.hIcon := Icon.Handle;
TrayIcon.szTip := 'StartRight - New Items found';
ShellAPI.Shell_notifyIcon(NIM_ADD, @TrayIcon);
icon.Free;
end;
{Old Move&Run method - replaced by 2 phase method}
{
procedure TFrmDummyRunner.DoMoveAndRun;
var CanMove : boolean;
begin
CanMove := sm.UserHasPermission;
if (not CanMove) then begin
ShowMessage('StartRight: Current user cannot alter system startup programs. Moving aborted.');
end;
self.ShowIcon;
if (FrmOptions.cbShowStartupDialog.Checked) then begin
self.Show;
end;
self.Callback_ProgramName('(Pausing ' +
IntToStr(sr.GetPrerunDelaySeconds) +
' seconds before executing)');
Application.ProcessMessages;
sr.ExecutePrerunDelay;
// copy new stuff, run everything
//
// NOTE: The autoexcluder will check for duplicate entries
// in my startup locations, and windows locations that may
// have occured after the last time StartRight was run.
self.Callback_ProgramName('(Moving new items)');
Application.ProcessMessages;
if (CanMove) then begin
ItemManager.AutoExcludeRunkeyItems;
ItemManager.AutoExcludeStartupItems;
end;
//
// dirty trick to get mover/runner to re-create data lists
// since the Exclude will change the mine and window's run keys
//
sm.Free;
sr.Free;
sm := TStartupMover.Create(self.Handle);
sr := TStartupRunner.Create(self.Handle);
if (CanMove) then begin
sm.MoveRunKeyItems;
sm.MoveStartupFolderItems;
end;
//
//
sr.ExecuteRunkeyPrograms;
sr.ExecuteStartupFolderPrograms;
self.HideIcon;
end;
}
{User Interations}
procedure TfrmDummyRunner.bStopClick(Sender: TObject);
begin
self.ModalResult := mrOk;
sr.Abort;
Application.Terminate;
Application.ProcessMessages;
end;
procedure TfrmDummyRunner.bPauseClick(Sender: TObject);
begin
if (bPause.Caption = 'Pause') then begin
bPause.Caption := 'Unpause';
sr.SetPaused(true);
self.paused := true;
end else begin
bPause.Caption := 'Pause';
sr.SetPaused(false);
self.paused := false;
end;
end;
function TfrmDummyRunner.IsPaused: boolean;
begin
result := paused;
end;
procedure TfrmDummyRunner.ClearRunOnceExecutedFlag;
var r : TMyRegistry;
begin
r := TMyRegistry.Create();
r.DeleteDataString(SR_HOME_KEY, SR_RUNONCE_VALUE);
end;
procedure TfrmDummyRunner.FlagRunOnceExecuted;
var r : TMyRegistry;
begin
r := TMyRegistry.Create();
r.SetDataString(SR_HOME_KEY, SR_RUNONCE_VALUE, SR_RUNONCE_VALUE);
end;
end.