Difference between revisions of "FileAssociation"

From Lazarus wiki
Jump to navigationJump to search
(Add some categories)
m (Remove duped platform template)
 
(14 intermediate revisions by 4 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 registers 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 [[FileAssociation#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;
 
    FActionText: string;
 
    FActionIcon: string;
 
    procedure SetRoot;
 
    procedure SetFAction(AValue: string);
 
    procedure SetFActionIcon(AValue: string);
 
    procedure SetFActionName(AValue: string);
 
    procedure SetFActionText(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);
 
  public
 
    constructor Create(AOwner: TComponent); override;
 
    destructor Destroy; override;
 
  public
 
    { String remove spaces }
 
    function StrNoSpaces(const s: string): string;
 
    { Add Root\SubKey\ ValueName=ValueData }
 
    function WriteStringValue(SubKey: string; ValueName: string;
 
      ValueData: string): boolean;
 
    { Delete Root\SuyKey\ ValueName=ValueData }
 
    function DeleteValue(SubKey: string; ValueName: string): boolean;
 
    { Add-Delete (UnReg option) Root\SubKey\ ValueName=ValueData }
 
    function WriteString(SubKey: string; ValueName: string; ValueData: string): boolean;
 
  public
 
    { 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;
 
    { Run all }
 
    function Execute: boolean;
 
    { Rebuild Icons }
 
    procedure ClearIconCache;
 
  published
 
    { Data }
 
    { 'Lazarus IDE' }
 
    property ApplicationName: string read FApplicationName write SetFApplicationName;
 
    { 'RAD for Free Pascal' }
 
    property ApplicationDescription: string
 
      read FApplicationDescription write SetFApplicationDescription;
 
    { '.lpr' }
 
    property Extension: string read FExtension write SetFExtension;
 
    { 'Lazarus Project' }
 
    property ExtensionName: string read FExtensionName write SetFExtensionName;
 
    { 'C:\lazarus\images\lprfile.ico' }
 
    property ExtensionIcon: string read FExtensionIcon write SetFExtensionIcon;
 
    { '"C:\lazarus\lazarus.exe" "%1"' }
 
    property Action: string read FAction write SetFAction;
 
    { 'Open' }
 
    property ActionName: string read FActionName write SetFActionName;
 
    { 'Open With Lazarus' or empty '' to use default MUI translation for 'Open', 'Print' and 'Edit' }
 
    property ActionText: string read FActionText write SetFActionText;
 
    { 'C:\lazarus\lazarus.exe,0' }
 
    property ActionIcon: string read FActionIcon write SetFActionIcon;
 
  published
 
    { Options }
 
    { True uses HKML, false HKCU }
 
    property RegisterForAllUsers: boolean read FRegisterForAllUsers
 
      write SetFRegisterForAllUsers default True;
 
    { Do '.lpr' association with 'Lazarus IDE' }
 
    property RegisterFileAssociation: boolean
 
      read FRegisterFileAssociation write SetFRegisterFileAssociation default True;
 
    { Add 'Lazarus IDE' to 'Default Programs' requires RegisterForAllUsers:True }
 
    property AddApplicationToDefaultPrograms: boolean
 
      read FAddApplicationToDefaultPrograms write SetFAddApplicationToDefaultPrograms default
 
      True;
 
    { Add '.lpr' to 'Lazarus IDE' in 'Default Programs' requires RegisterForAllUsers:True }
 
    property AddExtensionToDefaultPrograms: boolean
 
      read FAddExtensionToDefaultPrograms write SetFAddExtensionToDefaultPrograms default True;
 
    { Remove from registry the current data }
 
    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.SetRoot;
 
begin
 
  if RegisterForAllUsers then
 
    FRegistry.RootKey := HKEY_LOCAL_MACHINE
 
  else
 
    FRegistry.RootKey := HKEY_CURRENT_USER;
 
end;
 
 
 
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
 
  FRegisterForAllUsers := AValue;
 
  SetRoot;
 
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;
+
<syntaxhighlight lang="pascal">
begin
+
procedure TForm1.FormCreate(Sender: TObject);
  FRegistry.Free;
 
  inherited Destroy;
 
end;
 
 
 
function TFileAssociation.Execute: boolean;
 
 
var
 
var
   b1, b2, b3, b4, b5: boolean;
+
   s: String;
 
begin
 
begin
  b1 := WriteFileAssociationClass;
+
// if there are parameters
  b2 := WriteFileAssociationClassCommand;
+
   if ParamCount > 0 then
 
 
  if RegisterFileAssociation then
 
    b3 := WriteFileAssociation;
 
 
 
   if RegisterForAllUsers then
 
 
   begin
 
   begin
     if AddApplicationToDefaultPrograms then
+
// load the first parameter
      b4 := WriteDefaultPrograms;
+
     s := ParamStr(1);
     if AddExtensionToDefaultPrograms then
+
       b5 := WriteDefaultProgramsAddExt;
+
// 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;
 +
</syntaxhighlight>
  
  Result := False;
+
== Another way of registering file associations ==
  if b1 and b2 and b3 and b4 and b5 then
 
    Result := True;
 
end;
 
  
function TFileAssociation.WriteStringValue(SubKey: string; ValueName: string;
+
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.
  ValueData: string): boolean;
 
begin
 
  Result := FRegistry.OpenKey(SubKey, True);
 
  
  if Result then
+
<syntaxhighlight lang="pascal">
  begin
+
{$IFDEF WINDOWS}
    FRegistry.WriteString(ValueName, ValueData);
+
uses Registry, ShlObj;
    FRegistry.CloseKey;
+
  end;
+
procedure TMainForm.RegisterFileType(ExtName: string; AppName: string);
end;
+
var
 
+
  reg: TRegistry;
function TFileAssociation.DeleteValue(SubKey: string; ValueName: string): boolean;
 
 
begin
 
begin
   Result := FRegistry.OpenKey(SubKey, True);
+
   reg := TRegistry.Create;
  if Result then
+
  try
  begin
+
    reg.RootKey := HKEY_CLASSES_ROOT;
     FRegistry.DeleteValue(ValueName);
+
    reg.OpenKey('.' + ExtName, True);
     FRegistry.DeleteKey(ValueName);
+
    reg.WriteString('', ExtName + 'file');
     FRegistry.CloseKey;
+
    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;
 
   end;
end;
 
 
procedure TFileAssociation.SetFActionText(AValue: string);
 
begin
 
  if FActionText = AValue then
 
    Exit;
 
  FActionText := AValue;
 
end;
 
 
procedure TFileAssociation.ClearIconCache;
 
begin
 
 
   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, '', ActionText);
 
  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, '', '');
+
== See also ==
  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.
 
</syntaxhighlight>
 
  
[[Category:Code]]
+
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.
[[Category:FPC]]
 
[[Category:Lazarus]]
 
[[Category:Windows]]
 

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.