Difference between revisions of "FileAssociation"

From Lazarus wiki
Jump to navigationJump to search
(Version 2.0)
m (Remove duped platform template)
 
(18 intermediate revisions by 5 users not shown)
Line 1: Line 1:
 +
{{FileAssociation}}
 +
 
== TFileAssociation ==
 
== TFileAssociation ==
  
Author: (lainz-007-)
+
Author: Lainz
 +
 
 
Licence: Modified LGPL
 
Licence: Modified LGPL
Version: 2.0
 
  
This unit register file association for Windows.
+
Version: 1.0
 +
 
 +
Description: This unit registers file association for Windows.
  
== Notes ==
+
== Download ==
  
You must compile both 32 and 64 bit executable in Windows in order to register to Default Programs.
+
GitHub: https://github.com/lainz/FileAssociation
  
 
== Usage ==
 
== Usage ==
  
Save [[[TFileAssociation#Unit]]] to ufileassociation.pas to your hard drive and then try this:
+
First install the package. You can then drop the component TFileAssociation (FileAssoc unit) that gets installed in the [[System tab]] of the IDE on your [[TForm|form]].
 +
 
 +
All parameters are mandatory. Especially ActionName which must be 'Open' to work with double click. This is useful as well for default commands like 'Edit' and 'Print'. This must be in English for 'Edit', 'Open' and 'Print' so it can access the right registry entry. You can customize the translation with ActionText.
  
<syntaxhighlight>
+
<syntaxhighlight lang="pascal">
 
...
 
...
 
uses
 
uses
 
   ...
 
   ...
   ufileassociation;//<-- add fileassociation unit here
+
   FileAssoc; //<-- add fileassociation unit here
  
 
type
 
type
Line 44: Line 50:
 
   assoc.ExtensionIcon := '"C:\lazarus\images\lprfile.ico"';
 
   assoc.ExtensionIcon := '"C:\lazarus\images\lprfile.ico"';
  
   assoc.Action := '"C:\lazarus\lazarus.exe" "%1"';
+
  // full path required, you can use ParamStr(0) to get the path with the .exe name included. The path must be inside quotes if it has whitespace.
 +
   assoc.Action := '"C:\lazarus\lazarus.exe" "%1"';  
 
   assoc.ActionName := 'Open';
 
   assoc.ActionName := 'Open';
 
   assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"';
 
   assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"';
  
   assoc.RegisterForAllUsers:=True; //<-- you can change it to False and register for current user only
+
   // notice that using RegisterForAllUsers as True requires Administrator Privileges
 +
  // if you want to run without privileges set it to false, but it will register for current user only
 +
  assoc.RegisterForAllUsers:=False;
 
   if assoc.Execute then
 
   if assoc.Execute then
 
   begin
 
   begin
Line 59: Line 68:
 
</syntaxhighlight>
 
</syntaxhighlight>
  
== Unit ==
+
== How to open the associated file ==
 
 
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);
+
<syntaxhighlight lang="pascal">
begin
+
procedure TForm1.FormCreate(Sender: TObject);
  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;
+
   s: String;
 
begin
 
begin
  { Root }
+
// if there are parameters
  if RegisterForAllUsers then
+
   if ParamCount > 0 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);
+
// load the first parameter
     FRegistry.CloseKey;
+
     s := ParamStr(1);
 +
 +
// if is a .txt file
 +
    if ExtractFileExt(s) = '.txt' then
 +
    begin
 +
// load the .txt file into a memo
 +
      Memo1.Lines.LoadFromFile(s);
 +
     end;
 
   end;
 
   end;
end;
+
end;  
 +
</syntaxhighlight>
  
function TFileAssociation.DeleteValue(SubKey: string; ValueName: string): boolean;
+
== Another way of registering file associations ==
begin
 
  Result := FRegistry.OpenKey(SubKey, True);
 
  
  if Result then
+
Without using the component is as well possible to register a file association. This however doesn't cover adding the application to Default Programs, but is shorter if you only want to register a file type that's owned by your application.
  begin
 
    FRegistry.DeleteKey(ValueName);
 
    FRegistry.CloseKey;
 
  end;
 
end;
 
  
procedure TFileAssociation.ClearIconCache;
+
<syntaxhighlight lang="pascal">
 +
{$IFDEF WINDOWS}
 +
uses Registry, ShlObj;
 +
 +
procedure TMainForm.RegisterFileType(ExtName: string; AppName: string);
 +
var
 +
  reg: TRegistry;
 
begin
 
begin
 +
  reg := TRegistry.Create;
 +
  try
 +
    reg.RootKey := HKEY_CLASSES_ROOT;
 +
    reg.OpenKey('.' + ExtName, True);
 +
    reg.WriteString('', ExtName + 'file');
 +
    reg.CloseKey;
 +
    reg.CreateKey(ExtName + 'file');
 +
    reg.OpenKey(ExtName + 'file\DefaultIcon', True);
 +
    reg.WriteString('', AppName + ',0');
 +
    reg.CloseKey;
 +
    reg.OpenKey(ExtName + 'file\shell\open\command', True);
 +
    reg.WriteString('', AppName + ' "%1"');
 +
    reg.CloseKey;
 +
  finally
 +
    reg.Free;
 +
  end;
 
   SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
 
   SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
 
end;
 
end;
 +
{$ENDIF}
 +
</syntaxhighlight>
  
function TFileAssociation.StrNoSpaces(const s: string): string;
+
<syntaxhighlight lang="pascal">
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
 
var
  b1, b2: boolean;
+
  reg: TRegistry;
  sub: string;
+
     
 
begin
 
begin
   sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
+
   {$IFDEF WINDOWS}
    '.AssocFile.' + StrNoSpaces(ExtensionName);
+
   reg := TRegistry.Create;
 
+
   try
   b1 := WriteString(sub, '', ExtensionName);
+
    reg.RootKey := HKEY_CLASSES_ROOT;
   b2 := WriteString(sub + '\DefaultIcon', '', ExtensionIcon);
+
    if not reg.KeyExists('ext' + 'file\shell\open\command') then
 
+
      RegisterFileType('ext', ExtractFilePath(Application.ExeName) + 'my_app.exe');
  Result := False;
+
   finally
  if b1 and b2 then
+
     reg.Free;
    Result := True;
+
   end;
end;
+
 
+
if ParamCount > 0 then
function TFileAssociation.WriteFileAssociationClassCommand: boolean;
+
   begin
var
+
    s := ParamStr(1);
  b1, b2, b3: boolean;
+
    if ExtractFileExt(s) = '.ext' then
  sub: string;
+
      LoadFile(s);
begin
+
   end;
  sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
+
   {$ENDIF}
    '.AssocFile.' + StrNoSpaces(ExtensionName) + '\Shell\' + StrNoSpaces(ActionName);
+
</syntaxhighlight>
 
 
  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;
+
== See also ==
  if b1 and b2 and b3 and b4 then
 
    Result := True;
 
end;
 
  
function TFileAssociation.WriteDefaultProgramsAddExt: boolean;
+
If this component for some reason does not work for you, or you need to run it as administrator for all users without elevating your application privileges, an [[Inno_Setup_Usage#File_Association|Inno Setup Script]] may fit your needs best.
begin
 
  Result := WriteString('Software\' + StrNoSpaces(ApplicationName) +
 
    '\Capabilities\FileAssociations', Extension, StrNoSpaces(ApplicationName) +
 
    '.AssocFile.' + StrNoSpaces(ExtensionName));
 
end;
 
 
 
end.
 
</syntaxhighlight>
 

Latest revision as of 05:38, 15 February 2020

Windows logo - 2012.svg

This article applies to Windows only.

See also: Multiplatform Programming Guide

English (en) français (fr)

TFileAssociation

Author: Lainz

Licence: Modified LGPL

Version: 1.0

Description: This unit registers file association for Windows.

Download

GitHub: https://github.com/lainz/FileAssociation

Usage

First install the package. You can then drop the component TFileAssociation (FileAssoc unit) that gets installed in the System tab of the IDE on your form.

All parameters are mandatory. Especially ActionName which must be 'Open' to work with double click. This is useful as well for default commands like 'Edit' and 'Print'. This must be in English for 'Edit', 'Open' and 'Print' so it can access the right registry entry. You can customize the translation with ActionText.

...
uses
  ...
  FileAssoc; //<-- 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"';

  // full path required, you can use ParamStr(0) to get the path with the .exe name included. The path must be inside quotes if it has whitespace.
  assoc.Action := '"C:\lazarus\lazarus.exe" "%1"'; 
  assoc.ActionName := 'Open';
  assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"';

  // notice that using RegisterForAllUsers as True requires Administrator Privileges
  // if you want to run without privileges set it to false, but it will register for current user only
  assoc.RegisterForAllUsers:=False;
  if assoc.Execute then
  begin
    ShowMessage('OK');
    assoc.ClearIconCache; //<<-- rebuild icons
  end;
end;

end.

How to open the associated file

procedure TForm1.FormCreate(Sender: TObject);
var
  s: String;
begin
// if there are parameters
  if ParamCount > 0 then
  begin
// load the first parameter
    s := ParamStr(1);
 
// if is a .txt file
    if ExtractFileExt(s) = '.txt' then
    begin
// load the .txt file into a memo
      Memo1.Lines.LoadFromFile(s);
    end;
  end;
end;

Another way of registering file associations

Without using the component is as well possible to register a file association. This however doesn't cover adding the application to Default Programs, but is shorter if you only want to register a file type that's owned by your application.

{$IFDEF WINDOWS}
uses Registry, ShlObj;
 
procedure TMainForm.RegisterFileType(ExtName: string; AppName: string);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CLASSES_ROOT;
    reg.OpenKey('.' + ExtName, True);
    reg.WriteString('', ExtName + 'file');
    reg.CloseKey;
    reg.CreateKey(ExtName + 'file');
    reg.OpenKey(ExtName + 'file\DefaultIcon', True);
    reg.WriteString('', AppName + ',0');
    reg.CloseKey;
    reg.OpenKey(ExtName + 'file\shell\open\command', True);
    reg.WriteString('', AppName + ' "%1"');
    reg.CloseKey;
  finally
    reg.Free;
  end;
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;
{$ENDIF}
var
   reg: TRegistry;
       
begin
  {$IFDEF WINDOWS}
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CLASSES_ROOT;
    if not reg.KeyExists('ext' + 'file\shell\open\command') then
      RegisterFileType('ext', ExtractFilePath(Application.ExeName) + 'my_app.exe');
  finally
    reg.Free;
  end;
 
 if ParamCount > 0 then
  begin
    s := ParamStr(1);
    if ExtractFileExt(s) = '.ext' then
      LoadFile(s);
  end;
  {$ENDIF}

See also

If this component for some reason does not work for you, or you need to run it as administrator for all users without elevating your application privileges, an Inno Setup Script may fit your needs best.