Как получить список всех расширений и их ассоциаций?

Code:

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);

var

reg: TRegistry;

keys: TStringList;

i: Integer;

typename, displayname, server: string;

begin

memo1.Clear;

reg := TRegistry.Create;

try

   reg.rootkey := HKEY_CLASSES_ROOT;

   if reg.OpenKey('', False) then

   begin

     keys := TStringList.Create;

     try

       reg.GetKeyNames(keys);

       reg.CloseKey;

       {memo1.lines.addstrings(keys);}

       for i := 0 to keys.Count - 1 do

       begin

         if keys[i][1] = '.' then

         begin

           {this is an extension, get its typename}

           if reg.OpenKey(keys[i], False) then

           begin

             typename := reg.ReadString('');

             reg.CloseKey;

             if typename <> '' then

             begin

               if reg.OpenKey(typename, False) then

               begin

                 displayname := reg.ReadString('');

                 reg.CloseKey;

               end;

               if reg.OpenKey(typename + '\shell\open\command', False) then

               begin

                 server := reg.ReadString('');

                 memo1.Lines.Add(Format('Extension: "%s", Typename: "%s", Displayname:"%s"' +

                                        #13#10'  Server: %s',

                                        [keys[i], typename, displayname, server]));

                 reg.CloseKey;

               end;

             end;

           end;

         end;

       end;

     finally

       keys.Free;

     end;

   end;

finally

   reg.Free

end;

end;