source: oup/releases/0.31a/TFileTypeRegistration/ftypesAPI.pas

// -----------------------------------------------------------------------------
//
// TFileTypeRegistration-Klasse (Win32-API)
// Copyright (c) 2004 Mathias Simmack
//
// -----------------------------------------------------------------------------

// -- Revision history ---------------------------------------------------------
//
//   * erste Version
//
// -----------------------------------------------------------------------------
unit ftypesAPI;

interface

uses
  Windows, ShlObj;

type
  TFileTypeRegistration = class
    FRegConnector : HKEY;
    FExtension,
    FInternalName : string;
    FVerb         : string;
  public
    constructor Create;
    destructor Destroy; override;
    function RegisterType(const Extension, InternalName: string;
      Description: string = ''; IconFile: string = '';
      IconIndex: integer = -1): boolean;
    function UnregisterExtension(const Extension: string): boolean;
    function UnregisterType(const Extension: string): boolean;
    procedure UpdateShell;
    function AddHandler(const HandlerVerb, CommandLine: string;
      HandlerDescription: string = ''): boolean; overload;
    function DeleteHandler(const HandlerVerb: string): boolean;
    function SetDefaultHandler: boolean; overload;
    function SetDefaultHandler(const HandlerVerb: string): boolean; overload;
    function GetInternalKey(const Extension: string): string;
    function AddNewFileSupport(const Extension: string): boolean;
    function RemoveNewFileSupport(const Extension: string): boolean;

    property Extension: string read FExtension;
    property InternalName: string read FInternalName;
    property CurrentVerb: string read FVerb;
  end;


implementation

(* *****************************************************************************

  Beispiel #1: Einen neuen Dateityp registrieren
  ----------------------------------------------

  ftr := TFileTypeRegistration.Create;
  if(ftr <> nil) then
  try
    // die Dateiendung ".foo" registrieren, der interne Schlüssel
    // lautet "FooFile", eine Beschreibung und eine Symboldatei
    // sind ebenfalls angegeben
    if(ftr.RegisterType('.foo','FooFile','FOO Description',
      'c:\folder\icon.ico')) then
    begin
      // fügt den Handler "open" hinzu und verknüpft ihn mit dem
      // Programm "foo.exe"
      ftr.AddHandler('open','"c:\folder\foo.exe" "%1"');

      // setzt den zuletzt benutzten Handler ("open" in dem Fall)
      // als Standard
      ftr.SetDefaultHandler;
    end;

    if(ftr.RegisterType('.foo','ThisIsNotTheFOOKey')) then
    // Das ist kein Fehler! Obwohl hier der interne Name
    // "ThisIsNotTheFOOKey" verwendet wird, benutzt die Funktion
    // intern den bereits vorhandenen Schlüssel "FooFile" (s. oben).
    begin
      // zwei neue Handler werden registriert, ...
      ftr.AddHandler('print','"c:\folder\foo.exe" /p "%1"');
      ftr.AddHandler('edit','notepad.exe "%1"');

      // ... & dank der überladenen Funktion "SetDefaultHandler"
      // kann diesmal auch "print" als Standardhandler gesetzt
      // werden
      ftr.SetDefaultHandler('print');
    end;
  finally
    ftr.Free;
  end;


  Beispiel #2: Einen neuen Typ mit einem vorhandenen Schlüssel
  verknüpfen
  ------------------------------------------------------------

  Das Beispiel registriert die Endung ".foo" auf die gleiche
  Weise wie Textdateien (.txt). Es wird einfach der interne
  Schlüsselname ermittelt und für die Endung ".foo" gesetzt

  ftr := TFileTypeRegistration.Create;
  if(ftr <> nil) then
  try
    strInternalTextFileKey := ftr.GetInternalKey('.txt');
    if(strInternalTextFileKey <> '') then
      ftr.RegisterType('.foo',strInternalTextFileKey);
  finally
    ftr.Free;
  end;


  Beispiel #3: Einen Handler entfernen
  ------------------------------------

  ftr := TFileTypeRegistration.Create;
  if(ftr <> nil) then
  try
    // den internen Schlüsselnamen des Typs ".foo" ermitteln, ...
    if(ftr.GetInternalKey('.foo') <> '') then
    // ... wobei das Ergebnis in dem Fall unwichtig ist, weil
    // intern auch die Eigenschaft "FInternalName" gesetzt
    // wird
    begin
      // den "print"-Handler entfernen, ...
      ftr.DeleteHandler('print');

      // ... & den Standardhandler aktualisieren
      ftr.SetDefaultHandler('open');
    end;
  finally
    ftr.Free;
  end;


  Beispiel #4: Nur eine Dateiendung entfernen
  -------------------------------------------

  In diesem Fall wird lediglich die Endung ".foo" entfernt. Der
  evtl. vorhandene interne Schlüssel bleibt bestehen. Das ist
  für das Beispiel #2 nützlich, wenn die Endung ".foo" entfernt
  werden soll, intern aber mit den Textdateien verlinkt ist, die
  ja im Normalfall nicht entfernt werden dürfen/sollten.

    ftr.UnregisterExtension('.foo');


  Beispiel #5: Den kompletten Dateityp entfernen
  ----------------------------------------------

  Dieses Beispiel entfernt dagegen den kompletten Dateityp,
  inkl. des evtl. vorhandenen internen Schlüssels (vgl. mit
  Beispiel #4).

    ftr.UnregisterType('.foo');

  Bezogen auf Beispiel #2 wäre das die fatale Lösung, weil dadurch
  zwar die Endung ".foo" deregistriert wird, gleichzeitig wird
  aber auch der intern verwendete Schlüssel der Textdateien
  gelöscht.

  ALSO, VORSICHT!!!

***************************************************************************** *)


//
// Admin-Rechte sind erforderlich (Funktion von NicoDE)
//
{$INCLUDE IsAdmin.inc}
{$INCLUDE SysUtils.inc}


// -----------------------------------------------------------------------------
//
// Registry
//
// -----------------------------------------------------------------------------

function RegWriteSubKeyVal(const parent: HKEY; SubKeyName: string;
  ValueName, Value: string): boolean;
var
  tmp    : HKEY;
begin
  Result := false;
  if(parent = INVALID_HANDLE_VALUE) or
    (SubKeyName = '') then exit;

  if(RegCreateKeyEx(parent,pchar(SubKeyName),0,nil,0,KEY_READ or KEY_WRITE,
    nil,tmp,nil) = ERROR_SUCCESS) then
  try
    Result := (RegSetValueEx(tmp,pchar(ValueName),0,REG_SZ,pchar(Value),
      length(Value) + 1) = ERROR_SUCCESS);
  finally
    RegCloseKey(tmp);
  end;
end;

function RegReadSubKeyStr(const parent: HKEY; SubKeyName: string;
  ValueName: string): string;
var
  tmp     : HKEY;
  lpData,
  dwLen   : dword;
begin
  Result  := '';
  if(parent = INVALID_HANDLE_VALUE) or
    (SubKeyName = '') then exit;

  if(RegOpenKeyEx(parent,pchar(SubKeyName),0,KEY_READ,
    tmp) = ERROR_SUCCESS) then
  try
    lpData := REG_NONE;
    dwLen  := 0;
    if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,nil,
         @dwLen) = ERROR_SUCCESS) and
      (lpData in[REG_SZ,REG_EXPAND_SZ]) and
      (dwLen > 0) then
    begin
      SetLength(Result,dwLen);

      if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,
           @Result[1],@dwLen) = ERROR_SUCCESS) then
        SetLength(Result,dwLen - 1)
      else
        Result := '';
    end;
  finally
    RegCloseKey(tmp);
  end;
end;

function RegKeyExists(const parent: HKEY; KeyName: string): boolean;
var
  tmp    : HKEY;
begin
  Result := (RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,tmp) =
    ERROR_SUCCESS);
  if(Result) then RegCloseKey(tmp);
end;

function RegDeleteWholeKey(parent: HKEY; KeyName: string): boolean;
var
  reg       : HKEY;
  dwSubkeys : dword;
  dwLen     : dword;
  i         : integer;
  buf       : array[0..MAX_PATH]of char;
begin
  if(RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,reg) = ERROR_SUCCESS) then
  try
    if(RegQueryInfoKey(reg,nil,nil,nil,@dwSubKeys,nil,
      nil,nil,nil,nil,nil,nil) = ERROR_SUCCESS) and
      (dwSubKeys > 0) then
    for i := 0 to dwSubKeys - 1 do begin
      ZeroMemory(@buf,sizeof(buf));
      dwLen   := MAX_PATH;

      if(RegEnumKeyEx(reg,i,buf,dwLen,nil,nil,nil,nil) = ERROR_SUCCESS) and
        (dwLen > 0) then
      RegDeleteWholeKey(reg,buf);
    end;
  finally
    RegCloseKey(reg);
  end;

  Result := (RegDeleteKey(parent,pchar(KeyName)) = ERROR_SUCCESS);
end;


// -----------------------------------------------------------------------------
//
// TFileTypeRegistration-Klasse
//
// -----------------------------------------------------------------------------

constructor TFileTypeRegistration.Create;
var
  key: HKEY;
  sub: PChar;
begin
  FExtension    := '';
  FInternalName := '';
  FVerb         := '';

  // Zugriff auf die Registry, & HKEY_CLASSES_ROOT
  // als Root setzen
  if(WVersion='9X') or IsAdmin then begin
    key:=HKEY_CLASSES_ROOT;
    sub:=nil;
  end else begin
    key:=HKEY_CURRENT_USER;
    sub:=PChar('SOFTWARE\Classes');
  end;

  if RegOpenKeyEx(key,sub,0,KEY_ALL_ACCESS, FRegConnector) <> ERROR_SUCCESS then
    FRegConnector := INVALID_HANDLE_VALUE;
end;

destructor TFileTypeRegistration.Destroy;
begin
  if(FRegConnector <> INVALID_HANDLE_VALUE) then
    RegCloseKey(FRegConnector);
end;

function TFileTypeRegistration.RegisterType(const Extension,
  InternalName: string; Description: string = ''; IconFile: string = '';
  IconIndex: integer = -1): boolean;
var
  strDummy : string;
begin
  // Standardergebnis
  Result         := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  // ist dieser Typ evtl. schon registriert?
  strDummy := self.GetInternalKey(Extension);

  // Nein. :o)
  if(strDummy = '') then strDummy := InternalName;

  // den Schlüssel mit der Dateiendung anlegen oder aktualisieren
  Result := RegWriteSubKeyVal(FRegConnector,Extension,'',strDummy);
  if(not Result) then exit;

  // den internen Schlüssel öffnen
  if(Result) then
  begin
    // Beschreibung anlegen
    if(Description <> '') then
      RegWriteSubKeyVal(FRegConnector,strDummy,'',Description);

    // Symbol zuweisen (Datei muss existieren!)
    if(IconFile <> '') and
      (fileexists(IconFile)) then
    begin
      if(IconIndex <> -1) then
        RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
          '',Format('%s,%d',[IconFile,IconIndex]))
      else
        RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
          '',IconFile);
    end;
  end;

  // Systemsymbole aktualisieren
  self.UpdateShell;

  // Properties aktualisieren
  if(Result) then
  begin
    FExtension    := Extension;
    FInternalName := strDummy;
  end;
end;

function TFileTypeRegistration.UnregisterExtension(const Extension: string):
  boolean;
begin
  Result := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  // die Endung entfernen
  Result := (RegKeyExists(FRegConnector,Extension)) and
    (RegDeleteWholeKey(FRegConnector,Extension));

  // Systemsymbole aktualisieren
  self.UpdateShell;
end;

function TFileTypeRegistration.UnregisterType(const Extension: string):
  boolean;
var
  strDummy : string;
begin
  Result   := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  // den internen Namen der Endung ermitteln
  strDummy := self.GetInternalKey(Extension);

  // die Endung entfernen (s. "UnregisterExtension"), ...
  Result   := (self.UnregisterExtension(Extension)) and
  // ... & den internen Schlüssel löschen
    (strDummy <> '') and
    (RegKeyExists(FRegConnector,strDummy)) and
    (RegDeleteWholeKey(FRegConnector,strDummy));

  // Systemsymbole aktualisieren
  self.UpdateShell;
end;

procedure TFileTypeRegistration.UpdateShell;
begin
  SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST,nil,nil);
end;


const
  ShellKey = '%s\shell\%s';

function TFileTypeRegistration.AddHandler(const HandlerVerb,
  CommandLine: string; HandlerDescription: string = ''): boolean;
begin
  // Standardergebnis
  Result := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (FInternalName = '') or
    (HandlerVerb = '') or
    (CommandLine = '') then exit;

  // der interne Schlüssel muss existieren
  if(RegKeyExists(FRegConnector,FInternalName)) then
  begin
    // den Handler (= Verb) erzeugen
    Result := RegWriteSubKeyVal(FRegConnector,
      Format(ShellKey + '\command',[FInternalName,HandlerVerb]),
      '',
      CommandLine);

    // ggf. Beschreibung für Handler setzen
    if(HandlerDescription <> '') then
      RegWriteSubKeyVal(FRegConnector,
        Format(ShellKey,[FInternalName,HandlerVerb]),
        '',
        HandlerDescription);
  end;

  // interne Eigenschaft anpassen (für "SetDefaultHandler")
  if(Result) then
    FVerb := HandlerVerb;
end;

function TFileTypeRegistration.DeleteHandler(const HandlerVerb: string):
  boolean;
begin
  // Standardergebnis
  Result := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (FInternalName = '') or
    (HandlerVerb = '') then exit;

  // Handlerschlüssel entfernen (sofern vorhanden)
  Result :=
    (RegKeyExists(FRegConnector,
       Format(ShellKey,[FInternalName,HandlerVerb]))) and
    (RegDeleteWholeKey(FRegConnector,
       Format(ShellKey,[FInternalName,HandlerVerb])));
end;

function TFileTypeRegistration.SetDefaultHandler: boolean;
begin
  if(FInternalName <> '') and (FVerb <> '') then
    Result := self.SetDefaultHandler(FVerb)
  else
    Result := false;
end;

function TFileTypeRegistration.SetDefaultHandler(const HandlerVerb: string):
  boolean;
begin
  Result := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (FInternalName = '') or
    (HandlerVerb = '') then exit;

  // interner Schlüssel muss existieren, ...
  if(RegKeyExists(FRegConnector,FInternalName)) and
  // ... & Handler muss existieren, ...
    (RegKeyExists(FRegConnector,
       Format(ShellKey,[FInternalName,HandlerVerb]))) then
  begin
  // ... dann den Handler als Standard eintragen
    Result := RegWriteSubKeyVal(FRegConnector,FInternalName + '\shell',
      '',HandlerVerb);
  end;
end;

function TFileTypeRegistration.GetInternalKey(const Extension: string): string;
begin
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  // einen evtl. eingestellten internen Namen zurücksetzen
  FInternalName   := '';

  // den Schlüssel der Dateiendung öffnen, ...
  if(RegKeyExists(FRegConnector,Extension)) then
    FInternalName := RegReadSubKeyStr(FRegConnector,Extension,'');

  // ... als Funktionsergebnis zurückliefern
  if(not RegKeyExists(FRegConnector,FInternalName)) then
    FInternalName := '';

  Result := FInternalName;
end;


function TFileTypeRegistration.AddNewFileSupport(const Extension: string):
  boolean;
var
  Description : string;
begin
  Result      := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  // interne Beschreibung des Typs ermitteln
  if(self.GetInternalKey(Extension) <> '') then
    Description := RegReadSubKeyStr(FRegConnector,FInternalName,'')
  else
    Description := '';

  // die Beschreibung darf keine Leerzeichen enthalten, weil sie
  // als Referenz für den neuen Dateinamen verwendet wird, ...
  if(pos(#32,Description) > 0) or
  // ... & sie darf auch nicht leer sein
    (Description = '') then exit;

  Result := (RegKeyExists(FRegConnector,Extension)) and
    (RegWriteSubKeyVal(FRegConnector,Extension + '\ShellNew','NullFile',''));
end;

function TFileTypeRegistration.RemoveNewFileSupport(const Extension: string):
  boolean;
begin
  Result := false;
  if(FRegConnector = INVALID_HANDLE_VALUE) or
    (Extension = '') or
    (Extension[1] <> '.') then exit;

  Result := (RegKeyExists(FRegConnector,Extension + '\ShellNew')) and
    (RegDeleteWholeKey(FRegConnector,Extension + '\ShellNew'));
end;

end.