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

Unit Associations;  { Subset }
 
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; { CreateKey }
 
 
{+------------------------------------------------------------
 | 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; { InternalRegisterFiletype }
 
 
{+------------------------------------------------------------
[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; { RegisterFiletype }
 
 
{+------------------------------------------------------------
 | 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; { RegisterFileIcon }
 
 
 
{+------------------------------------------------------------
[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; { If }
          End; { If }
        End; { If }
      End; { If }
    Finally
      reg.free;
    End;
  End; { FiletypeIsRegistered }
End { Unit Associations }.