Difference between revisions of "FileAssociation"

From Lazarus wiki
Jump to navigationJump to search
m
(Updated Download Link)
Line 4: Line 4:
 
== 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 drop the component TFileAssociation (FileAssoc unit) that gets installed in the System tab of the IDE.
  
 
<syntaxhighlight>
 
<syntaxhighlight>
Line 22: Line 24:
 
uses
 
uses
 
   ...
 
   ...
−
   ufileassociation;//<-- add fileassociation unit here
+
   FileAssoc;//<-- add fileassociation unit here
  
 
type
 
type
Line 61: Line 63:
 
end.
 
end.
 
</syntaxhighlight>
 
</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;
 
−
    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;
 
−
begin
 
−
  FRegistry.Free;
 
−
  inherited Destroy;
 
−
end;
 
−
 
−
function TFileAssociation.Execute: boolean;
 
−
var
 
−
  b1, b2, b3, b4, b5: boolean;
 
−
begin
 
−
  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.DeleteValue(ValueName);
 
−
    FRegistry.DeleteKey(ValueName);
 
−
    FRegistry.CloseKey;
 
−
  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);
 
−
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, '', 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, '', '');
 
−
  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>
 
−
<br>
 

Revision as of 21:43, 22 December 2016

Windows logo - 2012.svg

This article applies to Windows only.

See also: Multiplatform Programming Guide

│ English (en) │ français (fr) │

Windows logo - 2012.svg

This article applies to Windows only.

See also: Multiplatform Programming Guide

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 drop the component TFileAssociation (FileAssoc unit) that gets installed in the System tab of the IDE. 

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

  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.
Retrieved from "http://wiki.freepascal.org/index.php?title=FileAssociation&oldid=106325"