source: oup/releases/0.29a3/TFileTypeRegistration/ftypesAPI.pas @ 32

Last change on this file since 32 was 32, checked in by alloc, 15 years ago
File size: 15.7 KB
Line 
1// -----------------------------------------------------------------------------
2//
3// TFileTypeRegistration-Klasse (Win32-API)
4// Copyright (c) 2004 Mathias Simmack
5//
6// -----------------------------------------------------------------------------
7
8// -- Revision history ---------------------------------------------------------
9//
10//   * erste Version
11//
12// -----------------------------------------------------------------------------
13unit ftypesAPI;
14
15interface
16
17uses
18  Windows, ShlObj;
19
20type
21  TFileTypeRegistration = class
22    FRegConnector : HKEY;
23    FExtension,
24    FInternalName : string;
25    FVerb         : string;
26  public
27    constructor Create;
28    destructor Destroy; override;
29    function RegisterType(const Extension, InternalName: string;
30      Description: string = ''; IconFile: string = '';
31      IconIndex: integer = -1): boolean;
32    function UnregisterExtension(const Extension: string): boolean;
33    function UnregisterType(const Extension: string): boolean;
34    procedure UpdateShell;
35    function AddHandler(const HandlerVerb, CommandLine: string;
36      HandlerDescription: string = ''): boolean; overload;
37    function DeleteHandler(const HandlerVerb: string): boolean;
38    function SetDefaultHandler: boolean; overload;
39    function SetDefaultHandler(const HandlerVerb: string): boolean; overload;
40    function GetInternalKey(const Extension: string): string;
41    function AddNewFileSupport(const Extension: string): boolean;
42    function RemoveNewFileSupport(const Extension: string): boolean;
43
44    property Extension: string read FExtension;
45    property InternalName: string read FInternalName;
46    property CurrentVerb: string read FVerb;
47  end;
48
49
50implementation
51
52(* *****************************************************************************
53
54  Beispiel #1: Einen neuen Dateityp registrieren
55  ----------------------------------------------
56
57  ftr := TFileTypeRegistration.Create;
58  if(ftr <> nil) then
59  try
60    // die Dateiendung ".foo" registrieren, der interne Schlüssel
61    // lautet "FooFile", eine Beschreibung und eine Symboldatei
62    // sind ebenfalls angegeben
63    if(ftr.RegisterType('.foo','FooFile','FOO Description',
64      'c:\folder\icon.ico')) then
65    begin
66      // fügt den Handler "open" hinzu und verknüpft ihn mit dem
67      // Programm "foo.exe"
68      ftr.AddHandler('open','"c:\folder\foo.exe" "%1"');
69
70      // setzt den zuletzt benutzten Handler ("open" in dem Fall)
71      // als Standard
72      ftr.SetDefaultHandler;
73    end;
74
75    if(ftr.RegisterType('.foo','ThisIsNotTheFOOKey')) then
76    // Das ist kein Fehler! Obwohl hier der interne Name
77    // "ThisIsNotTheFOOKey" verwendet wird, benutzt die Funktion
78    // intern den bereits vorhandenen Schlüssel "FooFile" (s. oben).
79    begin
80      // zwei neue Handler werden registriert, ...
81      ftr.AddHandler('print','"c:\folder\foo.exe" /p "%1"');
82      ftr.AddHandler('edit','notepad.exe "%1"');
83
84      // ... & dank der überladenen Funktion "SetDefaultHandler"
85      // kann diesmal auch "print" als Standardhandler gesetzt
86      // werden
87      ftr.SetDefaultHandler('print');
88    end;
89  finally
90    ftr.Free;
91  end;
92
93
94  Beispiel #2: Einen neuen Typ mit einem vorhandenen Schlüssel
95  verknüpfen
96  ------------------------------------------------------------
97
98  Das Beispiel registriert die Endung ".foo" auf die gleiche
99  Weise wie Textdateien (.txt). Es wird einfach der interne
100  Schlüsselname ermittelt und für die Endung ".foo" gesetzt
101
102  ftr := TFileTypeRegistration.Create;
103  if(ftr <> nil) then
104  try
105    strInternalTextFileKey := ftr.GetInternalKey('.txt');
106    if(strInternalTextFileKey <> '') then
107      ftr.RegisterType('.foo',strInternalTextFileKey);
108  finally
109    ftr.Free;
110  end;
111
112
113  Beispiel #3: Einen Handler entfernen
114  ------------------------------------
115
116  ftr := TFileTypeRegistration.Create;
117  if(ftr <> nil) then
118  try
119    // den internen Schlüsselnamen des Typs ".foo" ermitteln, ...
120    if(ftr.GetInternalKey('.foo') <> '') then
121    // ... wobei das Ergebnis in dem Fall unwichtig ist, weil
122    // intern auch die Eigenschaft "FInternalName" gesetzt
123    // wird
124    begin
125      // den "print"-Handler entfernen, ...
126      ftr.DeleteHandler('print');
127
128      // ... & den Standardhandler aktualisieren
129      ftr.SetDefaultHandler('open');
130    end;
131  finally
132    ftr.Free;
133  end;
134
135
136  Beispiel #4: Nur eine Dateiendung entfernen
137  -------------------------------------------
138
139  In diesem Fall wird lediglich die Endung ".foo" entfernt. Der
140  evtl. vorhandene interne Schlüssel bleibt bestehen. Das ist
141  für das Beispiel #2 nützlich, wenn die Endung ".foo" entfernt
142  werden soll, intern aber mit den Textdateien verlinkt ist, die
143  ja im Normalfall nicht entfernt werden dürfen/sollten.
144
145    ftr.UnregisterExtension('.foo');
146
147
148  Beispiel #5: Den kompletten Dateityp entfernen
149  ----------------------------------------------
150
151  Dieses Beispiel entfernt dagegen den kompletten Dateityp,
152  inkl. des evtl. vorhandenen internen Schlüssels (vgl. mit
153  Beispiel #4).
154
155    ftr.UnregisterType('.foo');
156
157  Bezogen auf Beispiel #2 wäre das die fatale Lösung, weil dadurch
158  zwar die Endung ".foo" deregistriert wird, gleichzeitig wird
159  aber auch der intern verwendete Schlüssel der Textdateien
160  gelöscht.
161
162  ALSO, VORSICHT!!!
163
164***************************************************************************** *)
165
166
167//
168// Admin-Rechte sind erforderlich (Funktion von NicoDE)
169//
170{$INCLUDE IsAdmin.inc}
171{$INCLUDE SysUtils.inc}
172
173
174// -----------------------------------------------------------------------------
175//
176// Registry
177//
178// -----------------------------------------------------------------------------
179
180function RegWriteSubKeyVal(const parent: HKEY; SubKeyName: string;
181  ValueName, Value: string): boolean;
182var
183  tmp    : HKEY;
184begin
185  Result := false;
186  if(parent = INVALID_HANDLE_VALUE) or
187    (SubKeyName = '') then exit;
188
189  if(RegCreateKeyEx(parent,pchar(SubKeyName),0,nil,0,KEY_READ or KEY_WRITE,
190    nil,tmp,nil) = ERROR_SUCCESS) then
191  try
192    Result := (RegSetValueEx(tmp,pchar(ValueName),0,REG_SZ,pchar(Value),
193      length(Value) + 1) = ERROR_SUCCESS);
194  finally
195    RegCloseKey(tmp);
196  end;
197end;
198
199function RegReadSubKeyStr(const parent: HKEY; SubKeyName: string;
200  ValueName: string): string;
201var
202  tmp     : HKEY;
203  lpData,
204  dwLen   : dword;
205begin
206  Result  := '';
207  if(parent = INVALID_HANDLE_VALUE) or
208    (SubKeyName = '') then exit;
209
210  if(RegOpenKeyEx(parent,pchar(SubKeyName),0,KEY_READ,
211    tmp) = ERROR_SUCCESS) then
212  try
213    lpData := REG_NONE;
214    dwLen  := 0;
215    if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,nil,
216         @dwLen) = ERROR_SUCCESS) and
217      (lpData in[REG_SZ,REG_EXPAND_SZ]) and
218      (dwLen > 0) then
219    begin
220      SetLength(Result,dwLen);
221
222      if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,
223           @Result[1],@dwLen) = ERROR_SUCCESS) then
224        SetLength(Result,dwLen - 1)
225      else
226        Result := '';
227    end;
228  finally
229    RegCloseKey(tmp);
230  end;
231end;
232
233function RegKeyExists(const parent: HKEY; KeyName: string): boolean;
234var
235  tmp    : HKEY;
236begin
237  Result := (RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,tmp) =
238    ERROR_SUCCESS);
239  if(Result) then RegCloseKey(tmp);
240end;
241
242function RegDeleteWholeKey(parent: HKEY; KeyName: string): boolean;
243var
244  reg       : HKEY;
245  dwSubkeys : dword;
246  dwLen     : dword;
247  i         : integer;
248  buf       : array[0..MAX_PATH]of char;
249begin
250  if(RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,reg) = ERROR_SUCCESS) then
251  try
252    if(RegQueryInfoKey(reg,nil,nil,nil,@dwSubKeys,nil,
253      nil,nil,nil,nil,nil,nil) = ERROR_SUCCESS) and
254      (dwSubKeys > 0) then
255    for i := 0 to dwSubKeys - 1 do begin
256      ZeroMemory(@buf,sizeof(buf));
257      dwLen   := MAX_PATH;
258
259      if(RegEnumKeyEx(reg,i,buf,dwLen,nil,nil,nil,nil) = ERROR_SUCCESS) and
260        (dwLen > 0) then
261      RegDeleteWholeKey(reg,buf);
262    end;
263  finally
264    RegCloseKey(reg);
265  end;
266
267  Result := (RegDeleteKey(parent,pchar(KeyName)) = ERROR_SUCCESS);
268end;
269
270
271// -----------------------------------------------------------------------------
272//
273// TFileTypeRegistration-Klasse
274//
275// -----------------------------------------------------------------------------
276
277constructor TFileTypeRegistration.Create;
278var
279  key: HKEY;
280  sub: PChar;
281begin
282  FExtension    := '';
283  FInternalName := '';
284  FVerb         := '';
285
286  // Zugriff auf die Registry, & HKEY_CLASSES_ROOT
287  // als Root setzen
288  if(WVersion='9X') or IsAdmin then begin
289    key:=HKEY_CLASSES_ROOT;
290    sub:=nil;
291  end else begin
292    key:=HKEY_CURRENT_USER;
293    sub:=PChar('SOFTWARE\Classes');
294  end;
295
296  if RegOpenKeyEx(key,sub,0,KEY_ALL_ACCESS, FRegConnector) <> ERROR_SUCCESS then
297    FRegConnector := INVALID_HANDLE_VALUE;
298end;
299
300destructor TFileTypeRegistration.Destroy;
301begin
302  if(FRegConnector <> INVALID_HANDLE_VALUE) then
303    RegCloseKey(FRegConnector);
304end;
305
306function TFileTypeRegistration.RegisterType(const Extension,
307  InternalName: string; Description: string = ''; IconFile: string = '';
308  IconIndex: integer = -1): boolean;
309var
310  strDummy : string;
311begin
312  // Standardergebnis
313  Result         := false;
314  if(FRegConnector = INVALID_HANDLE_VALUE) or
315    (Extension = '') or
316    (Extension[1] <> '.') then exit;
317
318  // ist dieser Typ evtl. schon registriert?
319  strDummy := self.GetInternalKey(Extension);
320
321  // Nein. :o)
322  if(strDummy = '') then strDummy := InternalName;
323
324  // den Schlüssel mit der Dateiendung anlegen oder aktualisieren
325  Result := RegWriteSubKeyVal(FRegConnector,Extension,'',strDummy);
326  if(not Result) then exit;
327
328  // den internen Schlüssel öffnen
329  if(Result) then
330  begin
331    // Beschreibung anlegen
332    if(Description <> '') then
333      RegWriteSubKeyVal(FRegConnector,strDummy,'',Description);
334
335    // Symbol zuweisen (Datei muss existieren!)
336    if(IconFile <> '') and
337      (fileexists(IconFile)) then
338    begin
339      if(IconIndex <> -1) then
340        RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
341          '',Format('%s,%d',[IconFile,IconIndex]))
342      else
343        RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
344          '',IconFile);
345    end;
346  end;
347
348  // Systemsymbole aktualisieren
349  self.UpdateShell;
350
351  // Properties aktualisieren
352  if(Result) then
353  begin
354    FExtension    := Extension;
355    FInternalName := strDummy;
356  end;
357end;
358
359function TFileTypeRegistration.UnregisterExtension(const Extension: string):
360  boolean;
361begin
362  Result := false;
363  if(FRegConnector = INVALID_HANDLE_VALUE) or
364    (Extension = '') or
365    (Extension[1] <> '.') then exit;
366
367  // die Endung entfernen
368  Result := (RegKeyExists(FRegConnector,Extension)) and
369    (RegDeleteWholeKey(FRegConnector,Extension));
370
371  // Systemsymbole aktualisieren
372  self.UpdateShell;
373end;
374
375function TFileTypeRegistration.UnregisterType(const Extension: string):
376  boolean;
377var
378  strDummy : string;
379begin
380  Result   := false;
381  if(FRegConnector = INVALID_HANDLE_VALUE) or
382    (Extension = '') or
383    (Extension[1] <> '.') then exit;
384
385  // den internen Namen der Endung ermitteln
386  strDummy := self.GetInternalKey(Extension);
387
388  // die Endung entfernen (s. "UnregisterExtension"), ...
389  Result   := (self.UnregisterExtension(Extension)) and
390  // ... & den internen Schlüssel löschen
391    (strDummy <> '') and
392    (RegKeyExists(FRegConnector,strDummy)) and
393    (RegDeleteWholeKey(FRegConnector,strDummy));
394
395  // Systemsymbole aktualisieren
396  self.UpdateShell;
397end;
398
399procedure TFileTypeRegistration.UpdateShell;
400begin
401  SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST,nil,nil);
402end;
403
404
405const
406  ShellKey = '%s\shell\%s';
407
408function TFileTypeRegistration.AddHandler(const HandlerVerb,
409  CommandLine: string; HandlerDescription: string = ''): boolean;
410begin
411  // Standardergebnis
412  Result := false;
413  if(FRegConnector = INVALID_HANDLE_VALUE) or
414    (FInternalName = '') or
415    (HandlerVerb = '') or
416    (CommandLine = '') then exit;
417
418  // der interne Schlüssel muss existieren
419  if(RegKeyExists(FRegConnector,FInternalName)) then
420  begin
421    // den Handler (= Verb) erzeugen
422    Result := RegWriteSubKeyVal(FRegConnector,
423      Format(ShellKey + '\command',[FInternalName,HandlerVerb]),
424      '',
425      CommandLine);
426
427    // ggf. Beschreibung für Handler setzen
428    if(HandlerDescription <> '') then
429      RegWriteSubKeyVal(FRegConnector,
430        Format(ShellKey,[FInternalName,HandlerVerb]),
431        '',
432        HandlerDescription);
433  end;
434
435  // interne Eigenschaft anpassen (für "SetDefaultHandler")
436  if(Result) then
437    FVerb := HandlerVerb;
438end;
439
440function TFileTypeRegistration.DeleteHandler(const HandlerVerb: string):
441  boolean;
442begin
443  // Standardergebnis
444  Result := false;
445  if(FRegConnector = INVALID_HANDLE_VALUE) or
446    (FInternalName = '') or
447    (HandlerVerb = '') then exit;
448
449  // Handlerschlüssel entfernen (sofern vorhanden)
450  Result :=
451    (RegKeyExists(FRegConnector,
452       Format(ShellKey,[FInternalName,HandlerVerb]))) and
453    (RegDeleteWholeKey(FRegConnector,
454       Format(ShellKey,[FInternalName,HandlerVerb])));
455end;
456
457function TFileTypeRegistration.SetDefaultHandler: boolean;
458begin
459  if(FInternalName <> '') and (FVerb <> '') then
460    Result := self.SetDefaultHandler(FVerb)
461  else
462    Result := false;
463end;
464
465function TFileTypeRegistration.SetDefaultHandler(const HandlerVerb: string):
466  boolean;
467begin
468  Result := false;
469  if(FRegConnector = INVALID_HANDLE_VALUE) or
470    (FInternalName = '') or
471    (HandlerVerb = '') then exit;
472
473  // interner Schlüssel muss existieren, ...
474  if(RegKeyExists(FRegConnector,FInternalName)) and
475  // ... & Handler muss existieren, ...
476    (RegKeyExists(FRegConnector,
477       Format(ShellKey,[FInternalName,HandlerVerb]))) then
478  begin
479  // ... dann den Handler als Standard eintragen
480    Result := RegWriteSubKeyVal(FRegConnector,FInternalName + '\shell',
481      '',HandlerVerb);
482  end;
483end;
484
485function TFileTypeRegistration.GetInternalKey(const Extension: string): string;
486begin
487  if(FRegConnector = INVALID_HANDLE_VALUE) or
488    (Extension = '') or
489    (Extension[1] <> '.') then exit;
490
491  // einen evtl. eingestellten internen Namen zurücksetzen
492  FInternalName   := '';
493
494  // den Schlüssel der Dateiendung öffnen, ...
495  if(RegKeyExists(FRegConnector,Extension)) then
496    FInternalName := RegReadSubKeyStr(FRegConnector,Extension,'');
497
498  // ... als Funktionsergebnis zurückliefern
499  if(not RegKeyExists(FRegConnector,FInternalName)) then
500    FInternalName := '';
501
502  Result := FInternalName;
503end;
504
505
506function TFileTypeRegistration.AddNewFileSupport(const Extension: string):
507  boolean;
508var
509  Description : string;
510begin
511  Result      := false;
512  if(FRegConnector = INVALID_HANDLE_VALUE) or
513    (Extension = '') or
514    (Extension[1] <> '.') then exit;
515
516  // interne Beschreibung des Typs ermitteln
517  if(self.GetInternalKey(Extension) <> '') then
518    Description := RegReadSubKeyStr(FRegConnector,FInternalName,'')
519  else
520    Description := '';
521
522  // die Beschreibung darf keine Leerzeichen enthalten, weil sie
523  // als Referenz für den neuen Dateinamen verwendet wird, ...
524  if(pos(#32,Description) > 0) or
525  // ... & sie darf auch nicht leer sein
526    (Description = '') then exit;
527
528  Result := (RegKeyExists(FRegConnector,Extension)) and
529    (RegWriteSubKeyVal(FRegConnector,Extension + '\ShellNew','NullFile',''));
530end;
531
532function TFileTypeRegistration.RemoveNewFileSupport(const Extension: string):
533  boolean;
534begin
535  Result := false;
536  if(FRegConnector = INVALID_HANDLE_VALUE) or
537    (Extension = '') or
538    (Extension[1] <> '.') then exit;
539
540  Result := (RegKeyExists(FRegConnector,Extension + '\ShellNew')) and
541    (RegDeleteWholeKey(FRegConnector,Extension + '\ShellNew'));
542end;
543
544end.
Note: See TracBrowser for help on using the repository browser.