home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chip 2001 September
/
Chip_2001-09_cd1.bin
/
zkuste
/
delphi
/
kompon
/
d2345
/
JSAPPEX.ZIP
/
src
/
AppEx.pas
< prev
Wrap
Pascal/Delphi Source File
|
2001-05-19
|
44KB
|
1,449 lines
////////////////////////////////////////////////////////////////////////////////
// Jazarsoft AppEx //
////////////////////////////////////////////////////////////////////////////////
// //
// VERSION : 2.2 //
// AUTHOR : James Azarja //
// CREATED : 10 July 2000 //
// MODIFIED : 19 May 2001 //
// WEBSITE : http://www.jazarsoft.com //
// SUPPORT : support@jazarsoft.com //
// BUG-REPORT : bugreport@jazarsoft.com //
// COMMENT : comment@jazarsoft.com //
// LEGAL : Copyright (C) 2000-2001 Jazarsoft. //
// //
////////////////////////////////////////////////////////////////////////////////
// //
// This code may be used and modified by anyone so long as this header and //
// copyright information remains intact. //
// //
// The code is provided "as-is" and without warranty of any kind, //
// expressed, implied or otherwise, including and without limitation, any //
// warranty of merchantability or fitness for a particular purpose.á //
// //
// In no event shall the author be liable for any special, incidental, //
// indirect or consequential damages whatsoever (including, without //
// limitation, damages for loss of profits, business interruption, loss //
// of information, or any other loss), whether or not advised of the //
// possibility of damage, and on any theory of liability, arising out of //
// or in connection with the use or inability to use this software.áá //
// //
////////////////////////////////////////////////////////////////////////////////
// //
// HISTORY : //
// //
// 1.0 : //
// Initial development //
// 1.1 : //
// + Last Compile Date, Last design date //
// + Parameter List //
// ╗ Parameter search routine //
// 1.2 : //
// + RunAsSecondCopy Event //
// + ExportResource Feature //
// + FileAssociation Feature //
// 1.3 : //
// ╗ Hide & Show on Task Bar Bug //
// 2.0 : //
// Major Code Reconstruction //
// + InfoRun Feature //
// + OnUserChanged Event //
// + OnDisplayChangedEvent //
// + Paramter..Found Event //
// 2.1 : //
// + Version Information //
// 2.2 : //
// + Hot Key Feature //
// //
// //
////////////////////////////////////////////////////////////////////////////////
{$WARNINGS OFF}
{$HINTS OFF}
unit AppEx;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Registry, IniFiles, DsgnIntf;
Type
THKModifier = (hkShift, hkCtrl, hkAlt, hkExt);
THKModifiers = set of THKModifier;
TVirtKey = (vkNone, vkCancel, vkBack, vkTab, vkClear, vkReturn, vkPause, vkCapital, vkEscape,
vkSpace, vkPrior, vkNext, vkEnd, vkHome, vkLeft, vkUp, vkRight, vkDown,
vkSelect, vkExecute, vkSnapshot, vkInsert, vkDelete, vkHelp,
vk0, vk1, vk2, vk3, vk4, vk5, vk6, vk7, vk8, vk9,
vkA, vkB, vkC, vkD, vkE, vkF, vkG, vkH, vkI, vkJ, vkK, vkL, vkM,
vkN, vkO, vkP, vkQ, vkR, vkS, vkT, vkU, vkV, vkW, vkX, vkY, vkZ,
vkNumpad0, vkNumpad1, vkNumpad2, vkNumpad3, vkNumpad4,
vkNumpad5, vkNumpad6, vkNumpad7, vkNumpad8, vkNumpad9,
vkMultiply, vkAdd, vkSeparator, vkSubtract, vkDecimal, vkDivide,
vkF1, vkF2, vkF3, vkF4, vkF5, vkF6, vkF7, vkF8, vkF9, vkF10, vkF11, vkF12,
vkF13, vkF14, vkF15, vkF16, vkF17, vkF18, vkF19, vkF20, vkF21, vkF22, vkF23, vkF24,
vkNumlock, vkScroll, vkApps,
vkSemiColon, vkEqual, vkComma, vkDash, vkDot, vkSlash, vkBackQuote,
vkBlockLeft, vkBackSlash, vkBlockRight, vkQuote);
Type
tAutoRunStyle = (arsLogin, arsStart, arsWarmBoot, arsFirstStart);
tPriorityClass = (pcNormal, pcIdle, pcHigh, pcRealtime);
TOnParameterFounded = procedure (Sender: TObject;Parameter:ShortString) of object;
TOnParameterValueFounded = procedure (Sender: TObject;Parameter,Ident,Value:ShortString) of object;
TOnDisplayChanged = Procedure (Sender: TObject;HorzRes,VertRes,ColorDepth : Integer) of object;
TOnEndSessionQuery = Procedure (Sender: TObject;Var EndSession:Boolean) of Object;
TOnHotKey = Procedure(Sender: TObject; Index: Integer) of object;
tFileExtInfo = Record
Extension : String;
ContentType : String;
HandlerName : String;
End;
tFileHandlerInfo = Record
HandlerName : String;
Description : String;
Icon : String;
End;
tFileShellInfo = Record
HandlerName : String;
Action : String; { Open, Print, Install, etc }
MenuCaption : String; { &Open, &Print, &Install, etc }
Command : String; { yourapp.exe %1 }
DDEString : String; { DDE Command }
DDEApp : String; { YOURAPPDDEID }
DDETopic : String; { YOUROWNTOPIC }
End;
PHotKeyItem = ^THotKeyItem;
THotKeyItem = record
Modifiers : THKModifiers;
VirtKey : TVirtKey;
Registered: Boolean;
end;
tExportResourceResult = (errOK,errNotFound,errLoadError,errFileExists);
THotKey = class (TPersistent)
private
FActive : Boolean;
FList : TList;
FParent : Hwnd;
procedure SetActive(Value : Boolean);
function GetCount: Integer;
protected
function ModifiersToFlag(Modifiers : THKModifiers): UInt;
procedure RegisterHotKeyNr(Index : Integer);
procedure UnregisterHotKeyNr(Index : Integer);
procedure RegisterHotKeys;
procedure UnregisterHotKeys;
public
Constructor Create(Parent:Hwnd);
Destructor Destroy;Override;
procedure Add(Item: THotKeyItem);
function AddHotKey(VirtKey: TVirtKey; Modifiers: THKModifiers): THotkeyItem;
procedure Clear;
procedure Delete(Index : Integer);
function Get(Index: Integer): THotKeyItem;
procedure Put(Index: Integer; Item: THotKeyItem);
{ runtime only properties }
property HotKeys[Index: Integer]: THotKeyItem read Get write Put; default;
property HotKeyCount: integer read GetCount;
published
property Enabled: Boolean read FActive write SetActive;
end;
TVerInfo = class (TPersistent)
private
FFileDescription : String;
FFileVersion : String;
FCompanyName : String;
FCopyright : String;
FTrademark : String;
FProductName : String;
FProductVersion : String;
protected
public
published
property FileDescription : String Read FFileDescription Write FFileDescription;
property FileVersion : String Read FFileVersion Write FFileVersion;
property CompanyName : String Read FCompanyName Write FCompanyName;
property Copyright : String Read FCopyright Write FCopyright;
property Trademark : String Read FTrademark Write FTrademark;
property ProductName : String Read FProductName Write FProductName;
property ProductVersion : String Read FProductVersion Write FProductVersion;
end;
TInfoRunInformation = class (TPersistent)
private
FStart : Integer;
FFinish : Integer;
FError : Integer;
FLastStart : TDateTime;
FLastFinish : TDateTime;
protected
public
published
property Start : Integer Read FStart Write FStart;
property Finish : Integer Read FFinish Write FFinish;
property Error : Integer Read FError Write FError;
property LastStart : tDateTime Read FLastStart Write FLastStart;
property LastFinish : tDateTime Read FLastFinish Write FLastFinish;
end;
TInfoRun = class (TPersistent)
private
FEnabled : Boolean;
FINIFilename : TFilename;
FInformation : TInfoRunInformation;
protected
public
Constructor Create;
Destructor Destroy;Override;
Procedure Start;
Procedure Finish;
Procedure Refresh;
published
property Enabled : Boolean Read FEnabled Write FEnabled;
property INIFilename : TFilename Read FIniFilename Write FIniFilename;
property Information : TInfoRunInformation Read FInformation Write FInformation;
end;
TAutoRun = class (TPersistent)
private
FAutoRunStyle : tAutoRunStyle;
FDescription : ShortString;
FExecutable : ShortString;
FGlobalAutoRun : Boolean;
Procedure SetDescription(Value:ShortString);
Procedure SetAutoRunStyle(Value:tAutoRunStyle);
Procedure SetExecutable(Value:ShortString);
Procedure SetAutoRun(Value:Boolean);
Function GetAutoRun:Boolean;
protected
public
Constructor Create;
Destructor Destroy;Override;
published
property Description : ShortString Read FDescription Write SetDescription;
property Style : tAutoRunStyle read FAutoRunStyle Write SetAutoRunStyle;
property Executable : ShortString Read FExecutable Write SetExecutable;
property Enabled : Boolean Read GetAutoRun Write SetAutoRun;
property Global : Boolean Read FGlobalAutoRun Write FGlobalAutoRun;
end;
TProcess = class (TPersistent)
private
FServiceProcess : Boolean;
FPriorityClass : tPriorityClass;
Procedure SetServiceProcess(Value:Boolean);
Function GetPriorityClass : tPriorityClass;
Procedure SetPriorityClass(Value:tPriorityClass);
protected
procedure ServiceProcessAction;
public
Constructor Create;
Destructor Destroy;Override;
published
property ServiceProcess : Boolean read FServiceProcess Write SetServiceProcess;
property PriorityClass : tPriorityClass Read GetPriorityClass Write SetPriorityClass;
end;
TSecurity = class (TPersistent)
private
FAntiSoftIce : Boolean;
protected
Function SoftIce95Loaded: boolean;
Function SoftIceNTLoaded: boolean;
public
Constructor Create;
Destructor Destroy;Override;
published
property AntiSoftIce : Boolean Read FAntiSoftIce Write FAntiSoftIce;
end;
TOnceRun = class (TPersistent)
private
FOnlyOnceRun : Boolean;
FAtomID : String;
AtomIndex : Word;
Procedure SetOnlyOnceRun(Value:Boolean);
protected
public
Constructor Create;
Destructor Destroy;Override;
published
property Enabled : Boolean Read FOnlyOncerun Write SetOnlyOnceRun;
property AtomID : String Read FAtomID write FAtomID;
end;
TAppEx = class(TComponent)
private
ParentHwnd : Hwnd;
PrevParentWndProc : Pointer;
SeekAndDestroy : Boolean;
FOnSoftIceRun : tNotifyEvent;
FShowTaskBar : Boolean;
FLastDesign : tDateTime;
FLastCompile : tDateTime;
FParameters : tStrings;
FOnParameterFounded : TOnParameterFounded;
FOnParameterValueFounded : TOnParameterValueFounded;
FOnRunAsSecondCopy : tNotifyEvent;
FAutoRun : TAutoRun;
FProcess : TProcess;
FSecurity : TSecurity;
FOnceRun : TOnceRun;
FInfoRun : TInfoRun;
FVerInfo : TVerInfo;
FHotKey : THotKey;
{ Events }
FOnUserChanged : tNotifyEvent;
FOnDisplayChanged : tOnDisplayChanged;
FOnEndSession : tOnEndSessionQuery;
{ HotKey }
FOnHotkey : tOnHotKey;
Procedure SetShowTaskbar(Value:Boolean);
Function GetLastDesign : tDateTime;
Function GetLastCompile: tDateTime;
protected
Procedure TaskAction;
Procedure ProcessParameters;
Procedure ReadVerInfo;
procedure NewParentWndProc(var Message:Tmessage);
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure Loaded;override;
Procedure UnInstall;
Procedure Flash(Flash,Time: Integer);
Function ExportResource(Name, Category, TargetFilename : String; Overwrite:Boolean):tExportResourceResult;
Procedure RegisterFileType(Ext, Description,Icon : String);
{ Your program must handler first parameter !, look for the code below }
published
property AutoRun : TAutoRun Read FAutoRun Write FAutoRun;
property Process : TProcess Read FProcess Write FProcess;
property Security : TSecurity Read FSecurity Write FSecurity;
property OnceRun : TOnceRun Read FOnceRun Write FOnceRun;
property InfoRun : TInfoRun Read FInfoRun Write FInfoRun;
property VersionInfo : TVerInfo Read FVerInfo Write FVerInfo;
property HotKey : THotKey Read FHotKey Write FHotKey;
property Parameters : tStrings Read FParameters Write FParameters;
property ShowOnTaskBar : Boolean read FShowTaskBar Write SetShowTaskBar;
property LastCompileDate : tDateTime read GetLastCompile write FLastCompile;
property LastDesignDate : tDateTime read GetLastDesign write FLastDesign;
Property OnSoftIceRun : TNotifyEvent Read FOnSoftIceRun Write FOnSoftIceRun;
property OnRunAsSecondCopy : tNotifyEvent Read FOnRunAsSecondCopy Write FOnRunAsSecondCopy;
property OnParameterFounded : TOnParameterFounded Read FOnParameterFounded Write FOnParameterFounded;
property OnParameterValueFounded : TOnParameterValueFounded Read FOnParameterValueFounded Write FOnParameterValueFounded;
property OnUserChanged : TNotifyEvent Read FOnUserChanged Write FOnUserChanged;
property OnDisplayChanged : TOnDisplayChanged Read FOnDisplayChanged Write FOnDisplayChanged;
property OnEndSession : TOnEndSessionQuery Read FOnEndSession Write FOnEndSession;
property OnHotKey : TOnHotKey Read FOnHotKey Write FOnHotKey;
End;
function KeyToVirtKey(const Key: Char): TVirtKey;
function HotKeyItem(const VirtKey: TVirtKey; Modifiers: THKModifiers): THotKeyItem;
procedure Register;
implementation
Var
VirtKeys : array[TVirtKey] of UInt =
($00, $03, $08, $09, $0C, $0D, $13, $14, $1B,
$20, $21, $22, $23, $24, $25, $26, $27, $28,
$29, $2B, $2C, $2D, $2E, $2F,
$30, $31, $32, $33, $34, $35, $36, $37, $38, $39,
$41, $42, $43, $44, $45, $46, $47, $48, $49, $4A,
$4B, $4C, $4D, $4E, $4F, $50, $51, $52, $53, $54,
$55, $56, $57, $58, $59, $5A,
$60, $61, $62, $63, $64, $65, $66, $67, $68, $69,
$6A, $6B, $6C, $6D, $6E, $6F,
$70, $71, $72, $73, $74, $75, $76, $77, $78, $79, $7A, $7B,
$7C, $7D, $7E, $7F, $80, $81, $82, $83, $84, $85, $86, $87,
$90, $91, $5D,
186, 187, 188, 189, 190, 191, 192, 219, 220, 221, 222);
Const
Run = 'Run'; { Run Every Login }
RunService = 'RunService'; { Run Every Windows Start }
RunServiceOnce = 'RunServiceOnce'; { Run Every Warm boot }
RunOnce = 'RunOnce'; { Run Every Windows First Start }
RunOnceEx = 'RunOnceEx'; { Run Every ? }
Var
Designing : Boolean;
function KeyToVirtKey(const Key: Char): TVirtKey;
var
i : TVirtKey;
KeyVal: UInt;
begin
Result := TVirtKey(0);
KeyVal := Ord(UpperCase(Key)[1]);
for i:= Low(TVirtKey) to High(TVirtKey) do
if KeyVal = VirtKeys[i] then
begin
Result := TVirtKey(i);
Exit;
end;
end;
function HotKeyItem(const VirtKey: TVirtKey; Modifiers: THKModifiers): THotKeyItem;
begin
Result.VirtKey := VirtKey;
Result.Modifiers := Modifiers;
Result.Registered := False;
end;
{ Miscellaneous Routines }
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
{ **** File Associate **** }
Procedure GetFileExtInfo(Var Info:tFileExtInfo);
Begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If OpenKey(Info.Extension,False) then
Begin
Info.ContentType := ReadString('Content Type');
Info.HandlerName := ReadString('');
CloseKey;
End;
Finally
Free;
End;
End;
Procedure SetFileExtInfo(Info:tFileExtInfo);
begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If OpenKey(Info.Extension,True) then
Begin
If Info.ContentType<>'' then WriteString('Content Type',Info.ContentType);
WriteString('',Info.HandlerName);
CloseKey;
End;
Finally
Free;
End;
End;
Procedure GetFileHandlerInfo(Var Info:tFileHandlerInfo);
Begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If OpenKey(Info.HandlerName,False) then
Begin
Info.Description := ReadString('');
CloseKey;
End;
If OpenKey(Info.HandlerName+'\DefaultIcon',False) then
Begin
Info.Icon := ReadString('');
CloseKey;
End;
Finally
Free;
End;
End;
Procedure SetFileHandlerInfo(Info:tFileHandlerInfo);
Begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If OpenKey(Info.HandlerName,True) then
Begin
WriteString('',Info.Description);
CloseKey;
End;
{ *** Optional *** }
If (Info.Icon<>'') and OpenKey(Info.HandlerName+'\DefaultIcon',True) then
Begin
WriteString('',Info.Icon);
CloseKey;
End;
Finally
Free;
End;
End;
Procedure GetFileShellInfo(Var Info:tFileShellInfo);
Begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If OpenKey(Info.HandlerName+'\shell\'+Info.Action,False) then
Begin
Info.MenuCaption := ReadString('');
CloseKey;
End;
If OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\command',False) then
Begin
Info.Command := ReadString('');
CloseKey;
End;
If OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec',False) then
Begin
Info.DDEString := ReadString('');
CloseKey;
End;
If OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec\Application',False) then
Begin
Info.DDEApp := ReadString('');
CloseKey;
End;
If OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec\Topic',False) then
Begin
Info.DDETopic := ReadString('');
CloseKey;
End;
Finally
Free;
End;
End;
Procedure SetFileShellInfo(Info:tFileShellInfo);
Begin
With TRegistry.Create do
Try
RootKey:=HKEY_CLASSES_ROOT;
If (Info.MenuCaption<>'') and OpenKey(Info.HandlerName+'\shell\'+Info.Action,True) then
Begin
WriteString('',Info.MenuCaption);
CloseKey;
End;
If (Info.Command<>'') and OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\command',True) then
Begin
WriteString('',Info.Command);
CloseKey;
End;
If (Info.DDEString<>'') and OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec',True) then
Begin
WriteString('',Info.DDEString);
CloseKey;
End;
If (Info.DDEApp<>'') and OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec\Application',True) then
Begin
WriteString('',Info.DDEApp);
CloseKey;
End;
If (Info.DDETopic<>'') and OpenKey(Info.HandlerName+'\shell\'+Info.Action+'\ddeexec\Topic',True) then
Begin
WriteString('',Info.DDETopic);
CloseKey;
End;
Finally
Free;
End;
End;
{ **** End of File Associate **** }
Procedure AddToAutoRun(Root:HKEY;Flag:String;AppDesc,Executable:String);
var reg:tregistry;
begin
Reg:=tRegistry.create;
With Reg do
Begin
RootKey:=Root;
Openkey('Software\Microsoft\Windows\CurrentVersion\'+Flag,true);
WriteString(AppDesc,Executable);
Closekey;
Free;
End;
End;
Function CheckFromAutoRun(Root:HKEY;Flag:String;AppDesc:String):Boolean;
var reg:tregistry;
begin
reg:=tregistry.create;
with reg do
begin
rootkey:=Root;
openkey('Software\Microsoft\Windows\CurrentVersion\'+Flag,true);
Result:=ValueExists(ApPDesc);
Closekey;
Free;
end;
end;
Procedure RemovefromAutoRun(Root:HKEY;Flag:String;AppDesc:String);
var reg:tregistry;
begin
reg:=tregistry.create;
with reg do
begin
Rootkey:=Root;
openkey('Software\Microsoft\Windows\CurrentVersion\'+Flag,true);
DeleteValue(AppDesc);
Closekey;
free;
end;
end;
{ Ext--> .txt, .bmp, .jpg }
Procedure tAutoRun.SetDescription(Value:ShortString);
Begin
If (Value<>FDescription) then
FDescription:=Value;
End;
function THotKey.ModifiersToFlag(Modifiers : THKModifiers): UInt;
begin
Result := 0;
if hkShift in Modifiers then Result := Result or MOD_SHIFT;
if hkCtrl in Modifiers then Result := Result or MOD_CONTROL;
if hkAlt in Modifiers then Result := Result or MOD_ALT;
if hkExt in Modifiers then Result := Result or MOD_WIN;
end;
procedure THotKey.RegisterHotKeyNr(Index : Integer);
begin
with PHotKeyItem(FList.Items[Index])^ do
Registered :=
WordBool(RegisterHotKey(FParent, Index,
ModifiersToFlag(Modifiers), VirtKeys[VirtKey]));
end;
procedure THotKey.UnRegisterHotKeyNr(Index : Integer);
begin
with PHotKeyItem(FList.Items[Index])^ do
if Registered then
begin
UnregisterHotKey(FParent, Index);
Registered := False;
end;
end;
procedure THotKey.RegisterHotKeys;
var
I : integer;
begin
for I:=0 to FList.Count-1 do
RegisterHotKeyNr(I);
end;
procedure THotKey.UnregisterHotKeys;
var
I : integer;
begin
for I:=0 to FList.Count-1 do
UnregisterHotKeyNr(I);
end;
procedure THotKey.SetActive(Value : Boolean);
begin
if FActive<>Value then
begin
FActive := Value;
if FActive then RegisterHotKeys else UnregisterHotKeys;
end;
end;
procedure THotKey.Add(Item: THotKeyItem);
begin
AddHotKey(Item.VirtKey, Item.Modifiers);
end;
function THotKey.AddHotKey(VirtKey: TVirtKey; Modifiers: THKModifiers): THotKeyItem;
var
pItem : PHotKeyItem;
iItem : Integer;
begin
pItem := PHotKeyItem(AllocMem(sizeof(THotKeyItem)));
pItem^.VirtKey := VirtKey;
pItem^.Modifiers := Modifiers;
iItem := FList.Add(pItem);
if FActive then RegisterHotKeyNr(iItem);
Result := pItem^;
end;
procedure THotKey.Clear;
var
I : integer;
begin
if FActive then UnregisterHotKeys;
for I:=0 to FList.Count-1 do
FreeMem(FList.Items[I]);
FList.Clear;
end;
procedure THotKey.Delete(Index : Integer);
begin
if FActive then UnregisterHotKeys;
FreeMem(FList.Items[Index]);
FList.Delete(Index);
FList.Pack;
if FActive then RegisterHotKeys;
end;
function THotKey.Get(Index: Integer): THotKeyItem;
begin
Result := THotKeyItem(FList.Items[Index]^);
end;
procedure THotKey.Put(Index: Integer; Item: THotKeyItem);
begin
if FActive then UnregisterHotKeyNr(Index);
with THotKeyItem(FList.Items[Index]^) do
begin
VirtKey := Item.VirtKey;
Modifiers := Item.Modifiers;
end;
if FActive then RegisterHotKeyNr(Index);
end;
function THotKey.GetCount: integer;
begin
Result := FList.Count;
end;
destructor THotKey.Destroy;
begin
inherited Destroy;
Clear;
FList.Free;
end;
constructor THotKey.Create(Parent:Hwnd);
begin
inherited Create;
FParent:=Parent;
FList := tList.Create;
end;
Procedure tAutoRun.SetAutoRunStyle(Value:tAutoRunStyle);
Begin
If (Value<>FAutoRunStyle) then
FAutoRunStyle:=Value;
End;
Procedure tAutoRun.SetExecutable(Value:ShortString);
Begin
If Not FileExists(Value) then
Begin
raise exception.create('Executable File not Found!');
End;
if not Designing then
If (Value<>FExecutable) then
FExecutable:=Value;
End;
Function TAutoRun.GetAutoRun:Boolean;
var Root : HKEY;
Flag : String;
Begin
Result:=False;
if Designing then exit;
If Global then Root:=HKEY_LOCAL_MACHINE else Root:=HKEY_CURRENT_USER;
If Style=arsLogin then Flag:=Run else
If Style=arsStart then Flag:=RunService else
If Style=arsWarmBoot then Flag:=RunServiceOnce else
If Style=arsFirstStart then Flag:=RunOnce;
Result:=CheckFromAutoRun(Root,Flag,Description);
End;
procedure TAutoRun.SetAutoRun(Value:Boolean);
var Root : HKEY;
Flag : String;
Begin
if Designing then exit;
If Global then Root:=HKEY_LOCAL_MACHINE else Root:=HKEY_CURRENT_USER;
If Style=arsLogin then Flag:=Run else
If Style=arsStart then Flag:=RunService else
If Style=arsWarmBoot then Flag:=RunServiceOnce else
If Style=arsFirstStart then Flag:=RunOnce;
If Value then
Begin
AddToAutoRun(Root,Flag,Description,Executable);
End else
RemoveFromAutoRun(Root,Flag,Description);
End;
destructor TAutoRun.Destroy;
begin
inherited Destroy;
end;
constructor TAutoRun.Create;
begin
inherited Create;
Style := arsLogin;
Global := True;
Enabled := False;
If Not Designing then
Begin
Description := (ExtractFilename(Application.ExeName));
Executable := Application.ExeName;
End;
end;
destructor TProcess.Destroy;
begin
inherited Destroy;
end;
constructor TProcess.Create;
begin
inherited Create;
ServiceProcess :=False;
PriorityClass :=pcNormal;
end;
Function TProcess.GetPriorityClass : tPriorityClass;
var PC : Integer;
Begin
Result:=pcNormal;
If Not Designing then
Begin
PC:=Windows.GetPriorityClass(GetCurrentProcess());
Case PC of
NORMAL_PRIORITY_CLASS : Result:=pcNormal;
IDLE_PRIORITY_CLASS : Result:=pcIdle;
HIGH_PRIORITY_CLASS : Result:=pcHigh;
REALTIME_PRIORITY_CLASS : Result:=pcRealTime;
End;
End;
End;
Procedure TProcess.SetPriorityClass(Value:tPriorityClass);
var PC : Integer;
Begin
If (Value<>FPriorityClass) then
Begin
FPriorityClass:=Value;
If Not Designing then
Begin
If FPriorityClass=pcNormal then PC:=NORMAL_PRIORITY_CLASS else
If FPriorityClass=pcIdle then PC:=IDLE_PRIORITY_CLASS else
If FPriorityClass=pcHigh then PC:=HIGH_PRIORITY_CLASS else
If FPriorityClass=pcRealTime then PC:=REALTIME_PRIORITY_CLASS;
Windows.SetPriorityClass(GetCurrentProcess,PC);
End;
End;
End;
Procedure TProcess.ServiceProcessAction;
Begin
if Designing then exit;
if FServiceProcess Then
RegisterServiceProcess(GetCurrentProcessID, 1)
else
RegisterServiceProcess(GetCurrentProcessID, 0);
End;
Procedure TProcess.SetServiceProcess(Value:Boolean);
begin
if (Value<>FServiceProcess) then
Begin
FServiceProcess := Value;
If Not Designing then
ServiceProcessAction;
End;
end;
destructor TSecurity.Destroy;
begin
inherited Destroy;
end;
constructor TSecurity.Create;
begin
inherited Create;
end;
Function TSecurity.SoftIce95Loaded: boolean;
Var hFile: Thandle;
Begin
Result := false;
hFile := CreateFileA('\\.\SICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;
Function TSecurity.SoftIceNTLoaded: boolean;
Var hFile: Thandle;
Begin
result := false;
hFile := CreateFileA('\\.\NTICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;
destructor TOnceRun.Destroy;
begin
If FOnlyOnceRun then
GlobalDeleteAtom(AtomIndex);
inherited Destroy;
end;
constructor TOnceRun.Create;
begin
inherited Create;
Enabled := False;
If Not Designing then
AtomId := ExtractFilename(Application.ExeName);
end;
Procedure TOnceRun.SetOnlyOnceRun(Value:Boolean);
Begin
If (Value<>FOnlyOnceRun) then
FOnlyOnceRun:=Value;
End;
constructor TInfoRun.Create;
begin
inherited Create;
FInformation:=TInfoRunInformation.Create;
If Not Designing then
Begin
FIniFilename := ChangeFileExt(Application.ExeName,'.AEX');
End;
end;
destructor TInfoRun.Destroy;
begin
FInformation.Free;
inherited Destroy;
end;
Procedure TInfoRun.Start;
Begin
If FIniFilename='' then Exit;
With TIniFile.Create(FIniFilename) do
Try
WriteInteger('InfoRun','Start',ReadInteger('InfoRun','Start',0)+1);
WriteDateTime('InfoRun','Last Start',Now);
Finally
Free;
End;
End;
Procedure TInfoRun.Finish;
Begin
If FIniFilename='' then Exit;
With TIniFile.Create(FIniFilename) do
Try
WriteInteger('InfoRun','Finish',ReadInteger('InfoRun','Finish',0)+1);
WriteDateTime('InfoRun','Last Finish',Now);
Finally
Free;
End;
End;
Procedure TInfoRun.Refresh;
Begin
If FIniFilename='' then Exit;
With TIniFile.Create(FIniFilename) do
Try
FInformation.Start:= ReadInteger('InfoRun','Start',0);
FInformation.Finish:=ReadInteger('InfoRun','Finish',0);
FInformation.LastStart:=ReadDateTime('InfoRun','Last Start',Now);
FInformation.LastStart:=ReadDateTime('InfoRun','Last Finish',Now);
If FInformation.Start > FInformation.Finish then
FInformation.Error:= FInformation.Start-FInformation.Finish else
FInformation.Error:=0;
Finally
Free;
End;
End;
Procedure TAppEx.RegisterFileType(Ext, Description, Icon : String);
var FileExtI : tFileExtInfo;
FileHandlerI : tFileHandlerInfo;
FileShellI : tFileShellInfo;
Begin
FileExtI.Extension:=Ext;
FileExtI.HandlerName:=Copy(Ext,Pos('.',Ext)+1, 3)+'file'; { .txt -> txtfile }
SetFileExtInfo(FileExtI);
FileHandlerI.HandlerName:=FileExtI.HandlerName;
FileHandlerI.Description:=Description;
FileHandlerI.Icon:=Icon;
SetFileHandlerInfo(FileHandlerI);
FileShellI.HandlerName:=FileExtI.HandlerName;
FileShellI.Action:='open'; { Open / Install / Print, etc }
FileShellI.Command:=Paramstr(0)+' %1';
SetFileShellInfo(FileShellI);
End;
Procedure tAppEx.SetShowTaskBar(Value:Boolean);
Begin
If Value<>FShowTaskBar then
Begin
FShowTaskBar:=Value;
If Not Designing then
TaskAction;
End;
End;
Constructor tAppEx.create(AOwner:TComponent);
var P : Pointer;
Begin
inherited Create(AOwner);
Designing := (csDesigning in ComponentState);
FShowTaskBar := true;
FParameters := tStringList.Create;
ParentHwnd := (AOwner as tForm).Handle;
FAutoRun := TAutoRun.Create;
FProcess := TProcess.Create;
FSecurity := TSecurity.Create;
FOnceRun := TOnceRun.Create;
FInfoRun := TInfoRun.Create;
FVerInfo := TVerInfo.Create;
FHotKey := THotKey.Create(ParentHwnd);
if not Designing then
Begin
PrevParentWndProc := Pointer(GetWindowLong(ParentHWnd, GWL_WNDPROC));
P := MakeObjectInstance(NewParentWndProc);
SetWindowLong(ParentHWnd, GWL_WNDPROC, LongInt(p));
ReadVerInfo;
End;
End;
Destructor tAppEx.destroy;
Begin
inherited destroy;
FAutoRun.Free;
FProcess.Free;
FSecurity.Free;
FOnceRun.Free;
FInfoRun.Free;
FVerInfo.Free;
FHotkey.Free;
if not Designing then
Begin
if not SeekAndDestroy then
begin
SetWindowLong(ParentHWnd, GWL_WNDPROC, LongInt(PrevParentWndProc));
end;
End;
FParameters.Free;
End;
procedure TAppEx.ReadVerInfo;
Var
VersionHandle,
VersionSize : Dword;
PItem,
PVersionInfo : Pointer;
FixedFileInfo :PVSFixedFileInfo;
Il : Uint;
Filename : String;
P : Array [0..MAX_PATH - 1] of char;
Begin
Filename:=Paramstr(0);
if Filename<>'' then
Begin
StrPCopy(P,Filename);
VersionSize:=GetFileVersionInfoSize(P,VersionHandle);
If VersionSize=0 Then Exit;
GetMem(PVersionInfo,VersionSize);
Try
If GetFileVersionInfo(P,VersionHandle,VersionSize,PVersionInfo) then
Begin
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\FileDescription'),pitem,il) then
FVerInfo.FileDescription:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\FileVersion'),pitem,il) then
FVerInfo.FileVersion:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\CompanyName'),pitem,il) then
FVerInfo.CompanyName:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\LegalCopyright'),pitem,il) then
FVerInfo.Copyright:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\LegalTrademark'),pitem,il) then
FVerInfo.Trademark:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\ProductName'),pitem,il) then
FVerInfo.ProductName:=Pchar(pitem);
if VerQueryValue(PVersionInfo,Pchar('\StringFileInfo\040904E4\ProductVersion'),pitem,il) then
FVerInfo.ProductVersion:=Pchar(pitem);
end;
Finally
FreeMem(pversioninfo,versionsize);
End;
End;
End;
Procedure tAppEx.ProcessParameters;
Var I : Integer;
Param : String;
Begin
For I:=1 to ParamCount do
Begin
Param:=ParamStr(I);
FParameters.Add(Param);
If Pos(':',Param)=0 then
Begin
If Assigned(FOnParameterFounded) then FOnParameterFounded(Self,Param);
end else
Begin
If Assigned(FOnParameterValueFounded) then
FOnParameterValueFounded(Self,Param, Copy(Param,1,Pos(':',Param)-1), Copy(Param,Pos(':',Param)+1,Length(Param)-Pos(':',Param)+1) ) else
End;
End;
End;
Procedure tAppEx.Loaded;
Begin
inherited Loaded;
if not Designing then
Begin
ProcessParameters;
// TaskAction;
if FOnceRun.Enabled then
begin
If (GlobalFindAtom(Pchar(FOnceRun.AtomID))=0) then
Begin
FOnceRun.AtomIndex:=GlobalAddAtom(Pchar(FOnceRun.AtomID));
End else
Begin
If Assigned(FOnRunAsSecondCopy) then
FOnRunAsSecondCopy(Self);
End;
end;
If FSecurity.AntiSoftIce then
Begin
if FSecurity.SoftIce95Loaded or FSecurity.SoftIceNTLoaded then
begin
If Assigned(FOnSoftICeRun) then FOnSoftIceRun(Self);
end;
End;
if FHotKey.Enabled then
Begin
FHotKey.RegisterHotKeys;
End;
End else
Begin
If FileExists(FInfoRun.INIFilename) then FInfoRun.Refresh;
End;
End;
Procedure tAppEx.Uninstall;
Var Tmp : Array[0..1024] of Char;
AppShortName,
Windir,
Buffer : String;
F : Textfile;
BackupFile : tStringList;
C : Word;
DoIt:Boolean;
Begin
If Not Designing Then
Begin
GetShortPathname(Pchar(Application.Exename),Tmp,1025);
AppShortName:=String(Tmp);
GetWindowsDirectory(Tmp,1025);
Windir:=String(Tmp);
If Length(Windir)>3 Then Windir:=Windir+'\';
Assignfile(F,Windir+'Wininit.Ini');
If Fileexists(Windir+'Wininit.Ini')=False Then
Begin
Rewrite(F);
Writeln(F,'[Rename]');
Writeln(F,'Nul='+Appshortname);
End Else
Begin
Backupfile:=Tstringlist.Create;
Reset(F);
While Not Eof(F) Do
Begin
Readln(F,Buffer);
Backupfile.Add(Buffer);
End;
Closefile(F);
Doit:=False;
For C:=0 To Backupfile.Count-1 Do
If Uppercase(Backupfile.Strings[C])='[Rename]' Then
Begin
Backupfile.Insert(C+1,'Nul='+Appshortname);
Doit:=True;
Break;
End;
Rewrite(F);
For C:=0 To Backupfile.Count-1 Do Writeln(F,Backupfile.Strings[C]);
If Doit=False Then
Begin
Writeln(F,'[Rename]');
Writeln(F,'Nul='+Appshortname);
End;
Backupfile.Free;
End;
Closefile(F);
End;
End;
Procedure TAppEx.TaskAction;
begin
if Not FShowTaskBar then
ShowWindow(FindWindow(nil,@Application.Title[1]),SW_HIDE) else
ShowWindow(FindWindow(nil,@Application.Title[1]),SW_RESTORE);
End;
procedure TAppEx.NewParentWndProc(var Message:Tmessage);
Var EndSession : Boolean;
SkipOldWndProc : Boolean;
Begin
SkipOldWndProc:=False;
With Message do
Begin
If (Msg=WM_HOTKEY) then
Begin
If Assigned(FOnHotKey) then FOnHotKey(Self,wParam);
end else
if (Msg = WM_CLOSE) or (Msg = WM_DESTROY) then
Begin
SeekAndDestroy := True;
End else
If (Msg=WM_SIZE) then
Begin
If (WParam=SIZE_MINIMIZED) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
End;
end else
If (Msg=WM_ACTIVATEAPP) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
end else
If (Msg=WM_WINDOWPOSCHANGED) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
end else
If (Msg=WM_NCACTIVATE) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
end else
If (Integer(MSG)>WM_USER) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
end else
If (Msg=WM_USERCHANGED) then
Begin
If Assigned(FOnUserChanged) then FOnUserChanged(Self);
end else
If (Msg=WM_DISPLAYCHANGE) then
Begin
If Assigned(FOnDisplayChanged) then FOnDisplayChanged(Self,lParamLo,lParamHi,wParam);
end else
If (Msg=WM_QUERYENDSESSION) then
Begin
If Assigned(FOnEndSession) then
Begin
EndSession:=True;
FOnEndSession(Self,EndSession);
Result:=Integer(EndSession);
SkipOldWndProc:=True;
End;
end else
If (Msg=WM_SHOWWINDOW) then
Begin
If Not FShowTaskBar then
Begin
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
TaskAction;
SkipOldWndProc:=True;
End;
end;
If Not SkipOldWndProc then
Result := CallWindowProc(PrevParentWndProc, ParentHWnd, Msg, WParam, LParam);
End;
End;
procedure TAppEx.Flash(Flash,Time:Integer);
var count:Integer;
begin
For Count:=1 to Flash do
Begin
FlashWindow(FindWindow(nil,@Application.Title[1]),true);
Sleep(Time);
End;
end;
Function TAppEx.GetLastDesign : tDateTime;
Begin
if Designing then Result := Now else Result:=FLastDesign;
End;
Function TAppEx.GetLastCompile: tDateTime;
Begin
if (csWriting in ComponentState) then Result := Now else Result:=FLastCompile;
End;
Function TAppEx.ExportResource(Name, Category, TargetFilename : String; Overwrite:Boolean):tExportResourceResult;
var
Res ,
ResHandle : THandle;
P : ^Char ;
N : Integer ;
FS : TFileStream ;
begin
Result := errOK ;
Res := FindResource (HInstance,PChar (Name),PChar(Category));
If Res <> 0 then
Begin
ResHandle := LoadResource (HInstance,Res);
If ResHandle <> 0 then
Begin
N := SizeOfResource (HInstance,Res);
P := LockResource (ResHandle);
If Not(FileExists (TargetFileName)) or Overwrite then
Begin
DeleteFile (Pchar(TargetFileName));
FS := TFileStream.Create (TargetFileName,fmCreate);
FS.Write (P^,N);
FS.Free;
UnLockResource(resHandle);
FreeResource(resHandle);
P := nil ;
end else
Begin
Result := errFileExists;
end;
end else
Begin
Result := errLoadError;
End;
end else
Begin
Result := errNotFound;
end ;
end;
procedure Register;
begin
RegisterComponents('Jazarsoft', [TAppEx]);
end;
end.