Difference between revisions of "FileAssociation"
From Free Pascal wiki
Jump to navigationJump to searchm (→License) |
(Version 2.0) |
||
Line 1: | Line 1: | ||
− | == | + | == TFileAssociation == |
− | + | Author: (lainz-007-) | |
+ | Licence: Modified LGPL | ||
+ | Version: 2.0 | ||
− | + | This unit register file association for Windows. | |
− | + | == Notes == | |
− | + | You must compile both 32 and 64 bit executable in Windows in order to register to Default Programs. | |
− | == | + | == Usage == |
− | |||
− | + | Save [[[TFileAssociation#Unit]]] to ufileassociation.pas to your hard drive and then try this: | |
− | |||
− | = | + | <syntaxhighlight> |
− | + | ... | |
+ | uses | ||
+ | ... | ||
+ | ufileassociation;//<-- add fileassociation unit here | ||
+ | |||
+ | type | ||
+ | |||
+ | ... | ||
+ | { private declarations } | ||
+ | assoc: TFileAssociation; | ||
+ | ... | ||
+ | |||
+ | procedure TfrmMain.FormCreate(Sender: TObject); | ||
+ | begin | ||
+ | assoc := TFileAssociation.Create(Self);//<-- create like a regular component | ||
+ | end; | ||
− | + | procedure TfrmMain.Button1Click(Sender: TObject); | |
− | + | begin | |
+ | assoc.ApplicationName := 'Lazarus IDE'; | ||
+ | assoc.ApplicationDescription := 'RAD for Free Pascal'; | ||
− | + | // you can change Extension and Action part for each extension you have | |
− | |||
− | == | + | assoc.Extension := '.lpr'; |
+ | assoc.ExtensionName := 'Lazarus Project'; | ||
+ | assoc.ExtensionIcon := '"C:\lazarus\images\lprfile.ico"'; | ||
− | + | assoc.Action := '"C:\lazarus\lazarus.exe" "%1"'; | |
+ | assoc.ActionName := 'Open'; | ||
+ | assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"'; | ||
− | = | + | assoc.RegisterForAllUsers:=True; //<-- you can change it to False and register for current user only |
+ | if assoc.Execute then | ||
+ | begin | ||
+ | ShowMessage('OK'); | ||
+ | assoc.ClearIconCache; //<<-- rebuild icons | ||
+ | end; | ||
+ | end; | ||
− | + | end. | |
+ | </syntaxhighlight> | ||
− | + | == Unit == | |
− | + | Version 2.0: It has all the stuff that v1.0 but it consumes less memory and it has been rewritten. | |
+ | Version 1.0: Initial. | ||
− | + | <syntaxhighlight> | |
+ | unit ufileassociation; | ||
+ | |||
+ | {$mode objfpc}{$H+} | ||
+ | |||
+ | interface | ||
+ | |||
+ | uses | ||
+ | Classes, SysUtils, Registry, ShlObj; | ||
+ | |||
+ | type | ||
+ | |||
+ | { TFileAssociation } | ||
+ | |||
+ | TFileAssociation = class(TComponent) | ||
+ | private | ||
+ | { Options } | ||
+ | FRegistry: TRegistry; | ||
+ | FRegisterForAllUsers: boolean; | ||
+ | FRegisterFileAssociation: boolean; | ||
+ | FAddApplicationToDefaultPrograms: boolean; | ||
+ | FAddExtensionToDefaultPrograms: boolean; | ||
+ | FUnReg: boolean; | ||
+ | { Data } | ||
+ | FApplicationName: string; | ||
+ | FApplicationDescription: string; | ||
+ | FExtension: string; | ||
+ | FExtensionName: string; | ||
+ | FExtensionIcon: string; | ||
+ | FAction: string; | ||
+ | FActionName: string; | ||
+ | FActionIcon: string; | ||
+ | procedure SetFAction(AValue: string); | ||
+ | procedure SetFActionIcon(AValue: string); | ||
+ | procedure SetFActionName(AValue: string); | ||
+ | procedure SetFApplicationDescription(AValue: string); | ||
+ | procedure SetFApplicationName(AValue: string); | ||
+ | procedure SetFExtension(AValue: string); | ||
+ | procedure SetFExtensionIcon(AValue: string); | ||
+ | procedure SetFExtensionName(AValue: string); | ||
+ | procedure SetFRegisterForAllUsers(AValue: boolean); | ||
+ | procedure SetFUnReg(AValue: boolean); | ||
+ | procedure SetFAddApplicationToDefaultPrograms(AValue: boolean); | ||
+ | procedure SetFAddExtensionToDefaultPrograms(AValue: boolean); | ||
+ | procedure SetFRegisterFileAssociation(AValue: boolean); | ||
+ | private | ||
+ | function WriteStringValue(SubKey: string; ValueName: string; | ||
+ | ValueData: string): boolean; | ||
+ | function DeleteValue(SubKey: string; ValueName: string): boolean; | ||
+ | private | ||
+ | { Add-Delete Root\SubKey\ ValueName=ValueData } | ||
+ | function WriteString(SubKey: string; ValueName: string; ValueData: string): boolean; | ||
+ | { Registry 'Class' containing the icon } | ||
+ | function WriteFileAssociationClass: boolean; | ||
+ | { Add a command like 'Open', 'Edit', 'Print' or other } | ||
+ | function WriteFileAssociationClassCommand: boolean; | ||
+ | { Associate the 'Class' with the file extension } | ||
+ | function WriteFileAssociation: boolean; | ||
+ | { Add application to Default Programs (Vista+) } | ||
+ | function WriteDefaultPrograms: boolean; | ||
+ | { Add extension to application Default Programs page } | ||
+ | function WriteDefaultProgramsAddExt: boolean; | ||
+ | { String remove spaces } | ||
+ | function StrNoSpaces(const s: string): string; | ||
+ | public | ||
+ | constructor Create(AOwner: TComponent); override; | ||
+ | destructor Destroy; override; | ||
+ | public | ||
+ | { Run } | ||
+ | function Execute: boolean; | ||
+ | { Rebuild Icons } | ||
+ | procedure ClearIconCache; | ||
+ | published | ||
+ | { Data } | ||
+ | property ApplicationName: string read FApplicationName write SetFApplicationName; | ||
+ | property ApplicationDescription: string | ||
+ | read FApplicationDescription write SetFApplicationDescription; | ||
+ | property Extension: string read FExtension write SetFExtension; | ||
+ | property ExtensionName: string read FExtensionName write SetFExtensionName; | ||
+ | property ExtensionIcon: string read FExtensionIcon write SetFExtensionIcon; | ||
+ | property Action: string read FAction write SetFAction; | ||
+ | property ActionName: string read FActionName write SetFActionName; | ||
+ | property ActionIcon: string read FActionIcon write SetFActionIcon; | ||
+ | published | ||
+ | { Options } | ||
+ | property RegisterForAllUsers: boolean read FRegisterForAllUsers | ||
+ | write SetFRegisterForAllUsers default True; | ||
+ | property RegisterFileAssociation: boolean | ||
+ | read FRegisterFileAssociation write SetFRegisterFileAssociation default True; | ||
+ | property AddApplicationToDefaultPrograms: boolean | ||
+ | read FAddApplicationToDefaultPrograms write SetFAddApplicationToDefaultPrograms default | ||
+ | True; | ||
+ | property AddExtensionToDefaultPrograms: boolean | ||
+ | read FAddExtensionToDefaultPrograms write SetFAddExtensionToDefaultPrograms default True; | ||
+ | property UnReg: boolean read FUnReg write SetFUnReg default False; | ||
+ | end; | ||
+ | |||
+ | procedure Register; | ||
+ | |||
+ | implementation | ||
+ | |||
+ | procedure Register; | ||
+ | begin | ||
+ | { $I fileassociation_icon.lrs} | ||
+ | RegisterComponents('System', [TFileAssociation]); | ||
+ | end; | ||
+ | |||
+ | { TFileAssociation } | ||
+ | |||
+ | procedure TFileAssociation.SetFAction(AValue: string); | ||
+ | begin | ||
+ | if FAction = AValue then | ||
+ | Exit; | ||
+ | FAction := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFActionIcon(AValue: string); | ||
+ | begin | ||
+ | if FActionIcon = AValue then | ||
+ | Exit; | ||
+ | FActionIcon := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFActionName(AValue: string); | ||
+ | begin | ||
+ | if FActionName = AValue then | ||
+ | Exit; | ||
+ | FActionName := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFApplicationDescription(AValue: string); | ||
+ | begin | ||
+ | if FApplicationDescription = AValue then | ||
+ | Exit; | ||
+ | FApplicationDescription := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFApplicationName(AValue: string); | ||
+ | begin | ||
+ | if FApplicationName = AValue then | ||
+ | Exit; | ||
+ | FApplicationName := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFExtension(AValue: string); | ||
+ | begin | ||
+ | if FExtension = AValue then | ||
+ | Exit; | ||
+ | FExtension := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFExtensionIcon(AValue: string); | ||
+ | begin | ||
+ | if FExtensionIcon = AValue then | ||
+ | Exit; | ||
+ | FExtensionIcon := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFExtensionName(AValue: string); | ||
+ | begin | ||
+ | if FExtensionName = AValue then | ||
+ | Exit; | ||
+ | FExtensionName := AValue; | ||
+ | end; | ||
+ | |||
+ | procedure TFileAssociation.SetFRegisterForAllUsers(AValue: boolean); | ||
+ | begin | ||
+ | if FRegisterForAllUsers = AValue then | ||
+ | Exit; | ||
+ | FRegisterForAllUsers := AValue; | ||
+ | end; | ||
− | + | procedure TFileAssociation.SetFUnReg(AValue: boolean); | |
+ | begin | ||
+ | if FUnReg = AValue then | ||
+ | Exit; | ||
+ | FUnReg := AValue; | ||
+ | end; | ||
− | + | procedure TFileAssociation.SetFAddApplicationToDefaultPrograms(AValue: boolean); | |
+ | begin | ||
+ | if FAddApplicationToDefaultPrograms = AValue then | ||
+ | Exit; | ||
+ | FAddApplicationToDefaultPrograms := AValue; | ||
+ | end; | ||
− | + | procedure TFileAssociation.SetFAddExtensionToDefaultPrograms(AValue: boolean); | |
+ | begin | ||
+ | if FAddExtensionToDefaultPrograms = AValue then | ||
+ | Exit; | ||
+ | FAddExtensionToDefaultPrograms := AValue; | ||
+ | end; | ||
− | + | procedure TFileAssociation.SetFRegisterFileAssociation(AValue: boolean); | |
+ | begin | ||
+ | if FRegisterFileAssociation = AValue then | ||
+ | Exit; | ||
+ | FRegisterFileAssociation := AValue; | ||
+ | end; | ||
− | + | constructor TFileAssociation.Create(AOwner: TComponent); | |
− | + | begin | |
− | + | inherited Create(AOwner); | |
+ | FRegistry := TRegistry.Create; | ||
+ | AddApplicationToDefaultPrograms := True; | ||
+ | AddExtensionToDefaultPrograms := True; | ||
+ | RegisterFileAssociation := True; | ||
+ | UnReg := False; | ||
+ | RegisterForAllUsers := True; | ||
+ | end; | ||
− | .. | + | destructor TFileAssociation.Destroy; |
+ | begin | ||
+ | FRegistry.Free; | ||
+ | inherited Destroy; | ||
+ | end; | ||
− | + | function TFileAssociation.Execute: boolean; | |
var | var | ||
− | + | b1, b2, b3, b4, b5: boolean; | |
− | |||
begin | begin | ||
− | + | { Root } | |
− | if | + | if RegisterForAllUsers then |
+ | FRegistry.RootKey := HKEY_LOCAL_MACHINE | ||
+ | else | ||
+ | FRegistry.RootKey := HKEY_CURRENT_USER; | ||
+ | |||
+ | b1 := WriteFileAssociationClass; | ||
+ | b2 := WriteFileAssociationClassCommand; | ||
+ | |||
+ | if RegisterFileAssociation then | ||
+ | b3 := WriteFileAssociation; | ||
+ | |||
+ | //if RegisterForAllUsers then | ||
+ | //begin | ||
+ | if AddApplicationToDefaultPrograms then | ||
+ | b4 := WriteDefaultPrograms; | ||
+ | if AddExtensionToDefaultPrograms then | ||
+ | b5 := WriteDefaultProgramsAddExt; | ||
+ | //end; | ||
+ | |||
+ | Result := False; | ||
+ | if b1 and b2 and b3 and b4 and b5 then | ||
+ | Result := True; | ||
+ | end; | ||
+ | |||
+ | function TFileAssociation.WriteStringValue(SubKey: string; ValueName: string; | ||
+ | ValueData: string): boolean; | ||
+ | begin | ||
+ | Result := FRegistry.OpenKey(SubKey, True); | ||
+ | |||
+ | if Result then | ||
begin | begin | ||
− | + | FRegistry.WriteString(ValueName, ValueData); | |
− | + | FRegistry.CloseKey; | |
+ | end; | ||
+ | end; | ||
− | + | function TFileAssociation.DeleteValue(SubKey: string; ValueName: string): boolean; | |
− | + | begin | |
− | + | Result := FRegistry.OpenKey(SubKey, True); | |
− | + | if Result then | |
− | + | begin | |
− | + | FRegistry.DeleteKey(ValueName); | |
− | + | FRegistry.CloseKey; | |
+ | end; | ||
+ | end; | ||
− | + | procedure TFileAssociation.ClearIconCache; | |
− | + | begin | |
− | + | SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil); | |
− | + | end; | |
− | + | ||
− | + | function TFileAssociation.StrNoSpaces(const s: string): string; | |
− | + | begin | |
− | + | Result := StringReplace(s, ' ', '', [rfReplaceAll]); | |
− | + | end; | |
− | + | ||
− | + | function TFileAssociation.WriteString(SubKey: string; ValueName: string; | |
− | + | ValueData: string): boolean; | |
− | + | begin | |
− | + | if not UnReg then | |
+ | Result := WriteStringValue(SubKey, ValueName, ValueData) | ||
+ | else | ||
+ | Result := DeleteValue(SubKey, ValueName); | ||
+ | end; | ||
+ | |||
+ | function TFileAssociation.WriteFileAssociationClass: boolean; | ||
+ | var | ||
+ | b1, b2: boolean; | ||
+ | sub: string; | ||
+ | begin | ||
+ | sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) + | ||
+ | '.AssocFile.' + StrNoSpaces(ExtensionName); | ||
+ | |||
+ | b1 := WriteString(sub, '', ExtensionName); | ||
+ | b2 := WriteString(sub + '\DefaultIcon', '', ExtensionIcon); | ||
− | + | Result := False; | |
− | + | if b1 and b2 then | |
+ | Result := True; | ||
+ | end; | ||
− | + | function TFileAssociation.WriteFileAssociationClassCommand: boolean; | |
− | + | var | |
− | + | b1, b2, b3: boolean; | |
− | + | sub: string; | |
− | + | begin | |
+ | sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) + | ||
+ | '.AssocFile.' + StrNoSpaces(ExtensionName) + '\Shell\' + StrNoSpaces(ActionName); | ||
− | + | b1 := WriteString(sub, '', ActionName); | |
− | + | b2 := WriteString(sub, 'Icon', ActionIcon); | |
− | + | b3 := WriteString(sub + '\Command', '', Action); | |
− | |||
− | |||
− | + | Result := False; | |
− | + | if b1 and b2 and b3 then | |
− | + | Result := True; | |
− | + | end; | |
− | |||
− | + | function TFileAssociation.WriteFileAssociation: boolean; | |
− | + | begin | |
− | + | Result := WriteString('Software\Classes\' + Extension, '', | |
− | + | StrNoSpaces(ApplicationName) + '.AssocFile.' + StrNoSpaces(ExtensionName)); | |
− | + | end; | |
− | + | function TFileAssociation.WriteDefaultPrograms: boolean; | |
− | + | var | |
− | + | b1, b2, b3, b4: boolean; | |
− | + | sub: string; | |
− | + | begin | |
+ | sub := 'Software\' + StrNoSpaces(ApplicationName) + '\Capabilities'; | ||
− | + | b1 := WriteString(sub, '', ''); | |
− | + | b2 := WriteString(sub, 'ApplicationName', ApplicationName); | |
− | + | b3 := WriteString(sub, 'ApplicationDescription', ApplicationDescription); | |
− | + | b4 := WriteString('Software\RegisteredApplications', | |
− | + | StrNoSpaces(ApplicationName), sub); | |
− | + | Result := False; | |
− | + | if b1 and b2 and b3 and b4 then | |
+ | Result := True; | ||
+ | end; | ||
− | + | function TFileAssociation.WriteDefaultProgramsAddExt: boolean; | |
− | + | begin | |
− | + | Result := WriteString('Software\' + StrNoSpaces(ApplicationName) + | |
− | + | '\Capabilities\FileAssociations', Extension, StrNoSpaces(ApplicationName) + | |
− | + | '.AssocFile.' + StrNoSpaces(ExtensionName)); | |
− | |||
− | |||
− | |||
− | |||
− | |||
end; | end; | ||
+ | |||
+ | end. | ||
</syntaxhighlight> | </syntaxhighlight> | ||
− | |||
− | |||
− |
Revision as of 19:45, 4 April 2014
TFileAssociation
Author: (lainz-007-) Licence: Modified LGPL Version: 2.0
This unit register file association for Windows.
Notes
You must compile both 32 and 64 bit executable in Windows in order to register to Default Programs.
Usage
Save [[[TFileAssociation#Unit]]] to ufileassociation.pas to your hard drive and then try this:
...
uses
...
ufileassociation;//<-- add fileassociation unit here
type
...
{ private declarations }
assoc: TFileAssociation;
...
procedure TfrmMain.FormCreate(Sender: TObject);
begin
assoc := TFileAssociation.Create(Self);//<-- create like a regular component
end;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
assoc.ApplicationName := 'Lazarus IDE';
assoc.ApplicationDescription := 'RAD for Free Pascal';
// you can change Extension and Action part for each extension you have
assoc.Extension := '.lpr';
assoc.ExtensionName := 'Lazarus Project';
assoc.ExtensionIcon := '"C:\lazarus\images\lprfile.ico"';
assoc.Action := '"C:\lazarus\lazarus.exe" "%1"';
assoc.ActionName := 'Open';
assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"';
assoc.RegisterForAllUsers:=True; //<-- you can change it to False and register for current user only
if assoc.Execute then
begin
ShowMessage('OK');
assoc.ClearIconCache; //<<-- rebuild icons
end;
end;
end.
Unit
Version 2.0: It has all the stuff that v1.0 but it consumes less memory and it has been rewritten. Version 1.0: Initial.
unit ufileassociation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Registry, ShlObj;
type
{ TFileAssociation }
TFileAssociation = class(TComponent)
private
{ Options }
FRegistry: TRegistry;
FRegisterForAllUsers: boolean;
FRegisterFileAssociation: boolean;
FAddApplicationToDefaultPrograms: boolean;
FAddExtensionToDefaultPrograms: boolean;
FUnReg: boolean;
{ Data }
FApplicationName: string;
FApplicationDescription: string;
FExtension: string;
FExtensionName: string;
FExtensionIcon: string;
FAction: string;
FActionName: string;
FActionIcon: string;
procedure SetFAction(AValue: string);
procedure SetFActionIcon(AValue: string);
procedure SetFActionName(AValue: string);
procedure SetFApplicationDescription(AValue: string);
procedure SetFApplicationName(AValue: string);
procedure SetFExtension(AValue: string);
procedure SetFExtensionIcon(AValue: string);
procedure SetFExtensionName(AValue: string);
procedure SetFRegisterForAllUsers(AValue: boolean);
procedure SetFUnReg(AValue: boolean);
procedure SetFAddApplicationToDefaultPrograms(AValue: boolean);
procedure SetFAddExtensionToDefaultPrograms(AValue: boolean);
procedure SetFRegisterFileAssociation(AValue: boolean);
private
function WriteStringValue(SubKey: string; ValueName: string;
ValueData: string): boolean;
function DeleteValue(SubKey: string; ValueName: string): boolean;
private
{ Add-Delete Root\SubKey\ ValueName=ValueData }
function WriteString(SubKey: string; ValueName: string; ValueData: string): boolean;
{ Registry 'Class' containing the icon }
function WriteFileAssociationClass: boolean;
{ Add a command like 'Open', 'Edit', 'Print' or other }
function WriteFileAssociationClassCommand: boolean;
{ Associate the 'Class' with the file extension }
function WriteFileAssociation: boolean;
{ Add application to Default Programs (Vista+) }
function WriteDefaultPrograms: boolean;
{ Add extension to application Default Programs page }
function WriteDefaultProgramsAddExt: boolean;
{ String remove spaces }
function StrNoSpaces(const s: string): string;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
public
{ Run }
function Execute: boolean;
{ Rebuild Icons }
procedure ClearIconCache;
published
{ Data }
property ApplicationName: string read FApplicationName write SetFApplicationName;
property ApplicationDescription: string
read FApplicationDescription write SetFApplicationDescription;
property Extension: string read FExtension write SetFExtension;
property ExtensionName: string read FExtensionName write SetFExtensionName;
property ExtensionIcon: string read FExtensionIcon write SetFExtensionIcon;
property Action: string read FAction write SetFAction;
property ActionName: string read FActionName write SetFActionName;
property ActionIcon: string read FActionIcon write SetFActionIcon;
published
{ Options }
property RegisterForAllUsers: boolean read FRegisterForAllUsers
write SetFRegisterForAllUsers default True;
property RegisterFileAssociation: boolean
read FRegisterFileAssociation write SetFRegisterFileAssociation default True;
property AddApplicationToDefaultPrograms: boolean
read FAddApplicationToDefaultPrograms write SetFAddApplicationToDefaultPrograms default
True;
property AddExtensionToDefaultPrograms: boolean
read FAddExtensionToDefaultPrograms write SetFAddExtensionToDefaultPrograms default True;
property UnReg: boolean read FUnReg write SetFUnReg default False;
end;
procedure Register;
implementation
procedure Register;
begin
{ $I fileassociation_icon.lrs}
RegisterComponents('System', [TFileAssociation]);
end;
{ TFileAssociation }
procedure TFileAssociation.SetFAction(AValue: string);
begin
if FAction = AValue then
Exit;
FAction := AValue;
end;
procedure TFileAssociation.SetFActionIcon(AValue: string);
begin
if FActionIcon = AValue then
Exit;
FActionIcon := AValue;
end;
procedure TFileAssociation.SetFActionName(AValue: string);
begin
if FActionName = AValue then
Exit;
FActionName := AValue;
end;
procedure TFileAssociation.SetFApplicationDescription(AValue: string);
begin
if FApplicationDescription = AValue then
Exit;
FApplicationDescription := AValue;
end;
procedure TFileAssociation.SetFApplicationName(AValue: string);
begin
if FApplicationName = AValue then
Exit;
FApplicationName := AValue;
end;
procedure TFileAssociation.SetFExtension(AValue: string);
begin
if FExtension = AValue then
Exit;
FExtension := AValue;
end;
procedure TFileAssociation.SetFExtensionIcon(AValue: string);
begin
if FExtensionIcon = AValue then
Exit;
FExtensionIcon := AValue;
end;
procedure TFileAssociation.SetFExtensionName(AValue: string);
begin
if FExtensionName = AValue then
Exit;
FExtensionName := AValue;
end;
procedure TFileAssociation.SetFRegisterForAllUsers(AValue: boolean);
begin
if FRegisterForAllUsers = AValue then
Exit;
FRegisterForAllUsers := AValue;
end;
procedure TFileAssociation.SetFUnReg(AValue: boolean);
begin
if FUnReg = AValue then
Exit;
FUnReg := AValue;
end;
procedure TFileAssociation.SetFAddApplicationToDefaultPrograms(AValue: boolean);
begin
if FAddApplicationToDefaultPrograms = AValue then
Exit;
FAddApplicationToDefaultPrograms := AValue;
end;
procedure TFileAssociation.SetFAddExtensionToDefaultPrograms(AValue: boolean);
begin
if FAddExtensionToDefaultPrograms = AValue then
Exit;
FAddExtensionToDefaultPrograms := AValue;
end;
procedure TFileAssociation.SetFRegisterFileAssociation(AValue: boolean);
begin
if FRegisterFileAssociation = AValue then
Exit;
FRegisterFileAssociation := AValue;
end;
constructor TFileAssociation.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FRegistry := TRegistry.Create;
AddApplicationToDefaultPrograms := True;
AddExtensionToDefaultPrograms := True;
RegisterFileAssociation := True;
UnReg := False;
RegisterForAllUsers := True;
end;
destructor TFileAssociation.Destroy;
begin
FRegistry.Free;
inherited Destroy;
end;
function TFileAssociation.Execute: boolean;
var
b1, b2, b3, b4, b5: boolean;
begin
{ Root }
if RegisterForAllUsers then
FRegistry.RootKey := HKEY_LOCAL_MACHINE
else
FRegistry.RootKey := HKEY_CURRENT_USER;
b1 := WriteFileAssociationClass;
b2 := WriteFileAssociationClassCommand;
if RegisterFileAssociation then
b3 := WriteFileAssociation;
//if RegisterForAllUsers then
//begin
if AddApplicationToDefaultPrograms then
b4 := WriteDefaultPrograms;
if AddExtensionToDefaultPrograms then
b5 := WriteDefaultProgramsAddExt;
//end;
Result := False;
if b1 and b2 and b3 and b4 and b5 then
Result := True;
end;
function TFileAssociation.WriteStringValue(SubKey: string; ValueName: string;
ValueData: string): boolean;
begin
Result := FRegistry.OpenKey(SubKey, True);
if Result then
begin
FRegistry.WriteString(ValueName, ValueData);
FRegistry.CloseKey;
end;
end;
function TFileAssociation.DeleteValue(SubKey: string; ValueName: string): boolean;
begin
Result := FRegistry.OpenKey(SubKey, True);
if Result then
begin
FRegistry.DeleteKey(ValueName);
FRegistry.CloseKey;
end;
end;
procedure TFileAssociation.ClearIconCache;
begin
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;
function TFileAssociation.StrNoSpaces(const s: string): string;
begin
Result := StringReplace(s, ' ', '', [rfReplaceAll]);
end;
function TFileAssociation.WriteString(SubKey: string; ValueName: string;
ValueData: string): boolean;
begin
if not UnReg then
Result := WriteStringValue(SubKey, ValueName, ValueData)
else
Result := DeleteValue(SubKey, ValueName);
end;
function TFileAssociation.WriteFileAssociationClass: boolean;
var
b1, b2: boolean;
sub: string;
begin
sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
'.AssocFile.' + StrNoSpaces(ExtensionName);
b1 := WriteString(sub, '', ExtensionName);
b2 := WriteString(sub + '\DefaultIcon', '', ExtensionIcon);
Result := False;
if b1 and b2 then
Result := True;
end;
function TFileAssociation.WriteFileAssociationClassCommand: boolean;
var
b1, b2, b3: boolean;
sub: string;
begin
sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
'.AssocFile.' + StrNoSpaces(ExtensionName) + '\Shell\' + StrNoSpaces(ActionName);
b1 := WriteString(sub, '', ActionName);
b2 := WriteString(sub, 'Icon', ActionIcon);
b3 := WriteString(sub + '\Command', '', Action);
Result := False;
if b1 and b2 and b3 then
Result := True;
end;
function TFileAssociation.WriteFileAssociation: boolean;
begin
Result := WriteString('Software\Classes\' + Extension, '',
StrNoSpaces(ApplicationName) + '.AssocFile.' + StrNoSpaces(ExtensionName));
end;
function TFileAssociation.WriteDefaultPrograms: boolean;
var
b1, b2, b3, b4: boolean;
sub: string;
begin
sub := 'Software\' + StrNoSpaces(ApplicationName) + '\Capabilities';
b1 := WriteString(sub, '', '');
b2 := WriteString(sub, 'ApplicationName', ApplicationName);
b3 := WriteString(sub, 'ApplicationDescription', ApplicationDescription);
b4 := WriteString('Software\RegisteredApplications',
StrNoSpaces(ApplicationName), sub);
Result := False;
if b1 and b2 and b3 and b4 then
Result := True;
end;
function TFileAssociation.WriteDefaultProgramsAddExt: boolean;
begin
Result := WriteString('Software\' + StrNoSpaces(ApplicationName) +
'\Capabilities\FileAssociations', Extension, StrNoSpaces(ApplicationName) +
'.AssocFile.' + StrNoSpaces(ExtensionName));
end;
end.