Работа с ассоциациями файла

Материал из DRKB

Работа с ассоциациями файла[править | править код]

unit Associations;

interface

procedure RegisterFiletype(const extension, filetype, description,
  verb: string; params: string);
procedure RegisterFileIcon(const filetype, iconsource: string;
  iconindex: cardinal);
function FiletypeIsRegistered(const extension, filetype: string): boolean;

implementation

uses Windows, Classes, SysUtils, Registry;

resourcestring
  eCannotCreateKey =
    'Cannot create key %s, the user account may not have the required ' +
    'rights to create registry keys under HKEY_CLASSES_ROOT.';

type
  ERegistryError = class(Exception);


{+------------------------------------------------------------
 | Procedure CreateKey
 |
 | Visibility : restricted to unit
 | Description:
 |   This is a helper function which uses the passed reg object
 |   to create a registry key.
 | Error Conditions:
 |   If the key cannot be created a ERegistryError exception is
 |   raised.
 | Created: 14.03.99 by P. Below
 +------------------------------------------------------------}
procedure CreateKey(reg: TRegistry; const keyname: string);
begin
  if not reg.OpenKey(keyname, True) then
    raise ERegistryError.CreateFmt(eCannotCreateKey, [keyname]);
end;


{+------------------------------------------------------------
 | Procedure InternalRegisterFiletype
 |
 | Parameters :
 |   extension  : file extension, including the dot, to register
 |   filetype   : string to use as key for the file extension
 |   description: string to show in Explorer for files with this
 |                extension. If description is empty the file
 |                type will not show up in Explorers list of
 |                registered associations!
 |   verb       : action to register, 'open', 'edit', 'print' etc.
 |                The action will turn up as entry in the files
 |                context menu in Explorer.
 |   serverapp  : full pathname of the executable to associate with
 |                the file extension, including any command line
 |                switches. Include the "%1" placeholder as well.
 |                Actions like printto may require more than one
 |                placeholder.
 | Visibility : restricted to unit
 | Description:
 |   Creates the three basic registry keys for a file extension.
 |   HKCR\<extension> = <filetype>
 |   HKCR\<filetype>  = <description>
 |   HKCR\<filetype>\shell\<verb>\command = <serverapp>
 |   If the keys already exist they are overwritten!
 | Error Conditions:
 |   A ERegistryError exception will result if a key cannot be
 |   created. Failure to create a key is usually due to insufficient
 |   user rights and only a problem on NT.
 | Created: 14.03.99 by P. Below
 +------------------------------------------------------------}
procedure InternalRegisterFiletype(
  const extension, filetype, description, verb, serverapp: string);
var
  reg: TRegistry;
  keystring: string;
begin
  reg := TRegistry.Create;
  try
    reg.Rootkey := HKEY_CLASSES_ROOT;
    CreateKey(reg, extension);
    reg.WriteString('', filetype);
    reg.CloseKey;
    CreateKey(reg, filetype);
    reg.WriteString('', description);
    reg.closekey;
    keystring := Format('%s\shell\%s\command', [filetype, verb]);
    CreateKey(reg, keystring);
    reg.WriteString('', serverapp);
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;


{+------------------------------------------------------------
[OBJECT]
 | Procedure RegisterFiletype
[OBJECT]
 |
 | Parameters :
 |   extension  : file extension, including the dot, to register
 |   filetype   : string to use as key for the file extension
 |   description: string to show in Explorer for files with this
 |                extension. If description is empty the file
 |                type will not show up in Explorers list of
 |                registered associations!
 |   verb       : action to register, 'open', 'edit', 'print' etc.
 |                The action will turn up as entry in the files
 |                context menu in Explorer.
 |   params     : The command line parameters to pass to the
 |                app when a file action is requested. If this
 |                parameter is empty "%1" is used by default.
 | Visibility : exported from unit
 | Description:
 |   Builds the commandline to use from the applications filename
 |   and the passed params and hands the rest of the work off to
 |   InternalRegisterFiletype.
 | Error Conditions: none
 | Created: 20.03.99 by P. Below
 +------------------------------------------------------------}
procedure RegisterFiletype(const extension, filetype, description,
  verb: string; params: string);
begin
  if Length(params) = 0 then
    params := '"%1"';
  InternalRegisterFiletype(
    extension, filetype, description, verb,
    ParamStr(0) + ' ' + params);
end;


{+------------------------------------------------------------
 | Procedure RegisterFileIcon
 |
 | Parameters :
 |   filetype  : file type key name to register the icon for
 |   iconsource: full pathname of the executable or ICO file
 |               that contains the icon
 |   iconindex : index of the icon to use, if several are containd
 |               in iconsource. Counts from 0!
 | Visibility : exported from unit
 | Description:
 |   Creates the registry keys required to tell Explorer which icon
 |   to display for files of this type. RegisterFileType needs
 |   to be called first to associate the filetype with an extension.
 |   The registry key added is
 |   HKCR\<filetype>\DefaultIcon = <iconsource>,<iconindex>
 |   If the key already exists it is overwritten!
 |   The icon specified should contain both large (32*32) and small
 |   (16*16) versions of the icon, to optain optimal display
 |    quality. If only one icon format is present Windows will
 |    generate the other from it.
 | Error Conditions:
 |   A ERegistryError exception will result if a key cannot be
 |   created. Failure to create a key is usually due to insufficient
 |   user rights and only a problem on NT.
 | Error Conditions: none
 | Created: 21.03.99 by P. Below
 +------------------------------------------------------------}
procedure RegisterFileIcon(const filetype, iconsource: string;
  iconindex: cardinal);
var
  reg: TRegistry;
  keystring: string;
begin
  reg := TRegistry.Create;
  try
    reg.Rootkey := HKEY_CLASSES_ROOT;
    keystring := Format('%s\DefaultIcon', [filetype]);
    CreateKey(reg, keystring);
    reg.WriteString('', Format('%s,%d', [iconsource, iconindex]));
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;


{+------------------------------------------------------------
[OBJECT]
 | Function FiletypeIsRegistered
[OBJECT]
 |
 | Parameters :
 |   extension  : file extension, including the dot, to search for
 |   filetype   : string to use as key for the file extension
 | Returns    : True if this application is registered as server
 |              for the 'open' action, false otherwise.
 | Visibility : exported from unit
 | Description:
 |   Checks if there is a registry entry for the passed extension,
 |   if it is associated with the expected file type and if this
 |   application is registered as server for the 'open' action.
 | Error Conditions: none
 | Created: 21.03.99 by P. Below
 +------------------------------------------------------------}
function FiletypeIsRegistered(const extension, filetype: string): boolean;
var
  reg: TRegistry;
  keystring: string;
begin
  Result := False;
  reg := TRegistry.Create;
  try
    reg.Rootkey := HKEY_CLASSES_ROOT;
    if reg.OpenKey(extension, False) then
    begin
      { Extension is registered, check filetype }
      keystring := reg.ReadString('');
      reg.Closekey;
      if CompareText(keystring, filetype) = 0 then
      begin
        { Filetype is registered for this extension, check server. }
        keystring := Format('%s\shell\open\command', [filetype]);
        if reg.OpenKey(keystring, False) then
        begin
          { Command key exists, but is this app the server? }
          keystring := UpperCase(reg.ReadString(''));
          reg.CloseKey;
          if Pos(UpperCase(ParamStr(0)), keystring) = 1 then
          begin
            { Yes, server matches! }
            Result := True;
          end;
        end;
      end;
    end;
  finally
    reg.Free;
  end;
end;

end.


Author: P. Below
ID: 01743