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

=== Работа с ассоциациями файла ===
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