uses Registry; 
 
procedure ExtensionsInfo(endg: string; gefunden: TStrings); 
var 
  typ, anzeige, Pgm: string; 
  sl: TStringList; 
  reg: TRegistry; 
  x: Integer; 
begin 
  screen.cursor := crHourGlass; 
  gefunden.Clear; 
  endg := lowercase(endg); 
  if Copy(endg, 1, 1) <> '.' then endg := '.' + endg; 
  reg := TRegistry.Create; 
  try 
    reg.rootkey := HKEY_CLASSES_ROOT; 
    if reg.OpenKey('', False) then 
    begin 
      sl := TStringList.Create; 
      try 
        reg.GetKeyNames(sl); 
        reg.CloseKey; 
        for x := 0 to sl.Count - 1 do 
        begin 
          if Copy(sl[x], 1, 1) = '.' then begin 
            if lowercase(sl[x]) = endg then 
              if reg.OpenKey(sl[x], False) then begin 
                typ := reg.ReadString(''); 
                reg.CloseKey; 
                if typ <> '' then begin 
                  if reg.OpenKey(typ, False) then begin 
                    anzeige := reg.ReadString(''); 
                    reg.CloseKey; 
                  end; 
                  if reg.OpenKey(typ + '\shell\open\command', False) 
                    then begin 
                    Pgm := reg.ReadString(''); 
                    gefunden.Add(Format('Endung: %s'#13#10 + 
                      'Typ-Name: %s'#13#10 + 
                      'Displayname: %s'#13#10'Server: %s', 
                      [sl[x], typ, anzeige, Pgm])); 
                    reg.CloseKey; 
                  end; 
                end; 
              end; 
          end; 
        end; 
      finally 
        sl.Free; 
      end; 
    end; 
  finally 
    reg.Free 
  end; 
  if gefunden.count = 0 then 
    gefunden.add('nicht gefunden'); 
  screen.cursor := crDefault; 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Memo1.ScrollBars := ssBoth; 
  ExtensionsInfo('.bmp', Memo1.Lines); 
end;