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

Last change on this file since 32 was 32, checked in by alloc, 19 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.