source: oup/current/ImportedStuff/FTypeReg.pas@ 1201

Last change on this file since 1201 was 93, checked in by alloc, 19 years ago
File size: 18.1 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 FTypeReg;
14
15interface
16
17uses
18 Windows, ShlObj, SysUtils;
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}
171function GetAdminSid: PSID;
172const
173 // bekannte SIDs ... (WinNT.h)
174 SECURITYNTAUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
175 // bekannte RIDs ... (WinNT.h)
176 SECURITYBUILTINDOMAINRID: DWORD = $00000020;
177 DOMAINALIASRIDADMINS: DWORD = $00000220;
178begin
179 Result := nil;
180 AllocateAndInitializeSid(SECURITYNTAUTHORITY, 2, SECURITYBUILTINDOMAINRID,
181 DOMAINALIASRIDADMINS, 0, 0, 0, 0, 0, 0, Result);
182end;
183
184function IsAdmin: LongBool;
185var
186 TokenHandle : THandle;
187 ReturnLength : DWORD;
188 TokenInformation : PTokenGroups;
189 AdminSid : PSID;
190 Loop : Integer;
191 wv : TOSVersionInfo;
192begin
193 wv.dwOSVersionInfoSize := sizeof(TOSversionInfo);
194 GetVersionEx(wv);
195
196 Result := (wv.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS);
197
198 if(wv.dwPlatformId = VER_PLATFORM_WIN32_NT) then
199 begin
200 TokenHandle := 0;
201 if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle) then
202 try
203 ReturnLength := 0;
204 GetTokenInformation(TokenHandle, TokenGroups, nil, 0, ReturnLength);
205 TokenInformation := GetMemory(ReturnLength);
206 if Assigned(TokenInformation) then
207 try
208 if GetTokenInformation(TokenHandle, TokenGroups,
209 TokenInformation, ReturnLength, ReturnLength) then
210 begin
211 AdminSid := GetAdminSid;
212 for Loop := 0 to TokenInformation^.GroupCount - 1 do
213 begin
214 if EqualSid(TokenInformation^.Groups[Loop].Sid, AdminSid) then
215 begin
216 Result := True;
217 break;
218 end;
219 end;
220 FreeSid(AdminSid);
221 end;
222 finally
223 FreeMemory(TokenInformation);
224 end;
225 finally
226 CloseHandle(TokenHandle);
227 end;
228 end;
229end;
230
231function WVersion: string;
232var
233 OSInfo: TOSVersionInfo;
234begin
235 Result := '3X';
236 OSInfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
237 GetVersionEx(OSInfo);
238 case OSInfo.dwPlatformID of
239 VER_PLATFORM_WIN32S: begin
240 Result := '3X';
241 Exit;
242 end;
243 VER_PLATFORM_WIN32_WINDOWS: begin
244 Result := '9X';
245 Exit;
246 end;
247 VER_PLATFORM_WIN32_NT: begin
248 Result := 'NT';
249 Exit;
250 end;
251 end; //case
252end;
253
254
255// -----------------------------------------------------------------------------
256//
257// Registry
258//
259// -----------------------------------------------------------------------------
260
261function RegWriteSubKeyVal(const parent: HKEY; SubKeyName: string;
262 ValueName, Value: string): boolean;
263var
264 tmp : HKEY;
265begin
266 Result := false;
267 if(parent = INVALID_HANDLE_VALUE) or
268 (SubKeyName = '') then exit;
269
270 if(RegCreateKeyEx(parent,pchar(SubKeyName),0,nil,0,KEY_READ or KEY_WRITE,
271 nil,tmp,nil) = ERROR_SUCCESS) then
272 try
273 Result := (RegSetValueEx(tmp,pchar(ValueName),0,REG_SZ,pchar(Value),
274 length(Value) + 1) = ERROR_SUCCESS);
275 finally
276 RegCloseKey(tmp);
277 end;
278end;
279
280function RegReadSubKeyStr(const parent: HKEY; SubKeyName: string;
281 ValueName: string): string;
282var
283 tmp : HKEY;
284 lpData,
285 dwLen : dword;
286begin
287 Result := '';
288 if(parent = INVALID_HANDLE_VALUE) or
289 (SubKeyName = '') then exit;
290
291 if(RegOpenKeyEx(parent,pchar(SubKeyName),0,KEY_READ,
292 tmp) = ERROR_SUCCESS) then
293 try
294 lpData := REG_NONE;
295 dwLen := 0;
296 if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,nil,
297 @dwLen) = ERROR_SUCCESS) and
298 (lpData in[REG_SZ,REG_EXPAND_SZ]) and
299 (dwLen > 0) then
300 begin
301 SetLength(Result,dwLen);
302
303 if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,
304 @Result[1],@dwLen) = ERROR_SUCCESS) then
305 SetLength(Result,dwLen - 1)
306 else
307 Result := '';
308 end;
309 finally
310 RegCloseKey(tmp);
311 end;
312end;
313
314function RegKeyExists(const parent: HKEY; KeyName: string): boolean;
315var
316 tmp : HKEY;
317begin
318 Result := (RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,tmp) =
319 ERROR_SUCCESS);
320 if(Result) then RegCloseKey(tmp);
321end;
322
323function RegDeleteWholeKey(parent: HKEY; KeyName: string): boolean;
324var
325 reg : HKEY;
326 dwSubkeys : dword;
327 dwLen : dword;
328 i : integer;
329 buf : array[0..MAX_PATH]of char;
330begin
331 if(RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,reg) = ERROR_SUCCESS) then
332 try
333 if(RegQueryInfoKey(reg,nil,nil,nil,@dwSubKeys,nil,
334 nil,nil,nil,nil,nil,nil) = ERROR_SUCCESS) and
335 (dwSubKeys > 0) then
336 for i := 0 to dwSubKeys - 1 do begin
337 ZeroMemory(@buf,sizeof(buf));
338 dwLen := MAX_PATH;
339
340 if(RegEnumKeyEx(reg,i,buf,dwLen,nil,nil,nil,nil) = ERROR_SUCCESS) and
341 (dwLen > 0) then
342 RegDeleteWholeKey(reg,buf);
343 end;
344 finally
345 RegCloseKey(reg);
346 end;
347
348 Result := (RegDeleteKey(parent,pchar(KeyName)) = ERROR_SUCCESS);
349end;
350
351
352// -----------------------------------------------------------------------------
353//
354// TFileTypeRegistration-Klasse
355//
356// -----------------------------------------------------------------------------
357
358constructor TFileTypeRegistration.Create;
359var
360 key: HKEY;
361 sub: PChar;
362begin
363 FExtension := '';
364 FInternalName := '';
365 FVerb := '';
366
367 // Zugriff auf die Registry, & HKEY_CLASSES_ROOT
368 // als Root setzen
369 if(WVersion='9X') or IsAdmin then begin
370 key:=HKEY_CLASSES_ROOT;
371 sub:=nil;
372 end else begin
373 key:=HKEY_CURRENT_USER;
374 sub:=PChar('SOFTWARE\Classes');
375 end;
376
377 if RegOpenKeyEx(key,sub,0,KEY_ALL_ACCESS, FRegConnector) <> ERROR_SUCCESS then
378 FRegConnector := INVALID_HANDLE_VALUE;
379end;
380
381destructor TFileTypeRegistration.Destroy;
382begin
383 if(FRegConnector <> INVALID_HANDLE_VALUE) then
384 RegCloseKey(FRegConnector);
385end;
386
387function TFileTypeRegistration.RegisterType(const Extension,
388 InternalName: string; Description: string = ''; IconFile: string = '';
389 IconIndex: integer = -1): boolean;
390var
391 strDummy : string;
392begin
393 // Standardergebnis
394 Result := false;
395 if(FRegConnector = INVALID_HANDLE_VALUE) or
396 (Extension = '') or
397 (Extension[1] <> '.') then exit;
398
399 // ist dieser Typ evtl. schon registriert?
400 strDummy := self.GetInternalKey(Extension);
401
402 // Nein. :o)
403 if(strDummy = '') then strDummy := InternalName;
404
405 // den Schlüssel mit der Dateiendung anlegen oder aktualisieren
406 Result := RegWriteSubKeyVal(FRegConnector,Extension,'',strDummy);
407 if(not Result) then exit;
408
409 // den internen Schlüssel öffnen
410 if(Result) then
411 begin
412 // Beschreibung anlegen
413 if(Description <> '') then
414 RegWriteSubKeyVal(FRegConnector,strDummy,'',Description);
415
416 // Symbol zuweisen (Datei muss existieren!)
417 if(IconFile <> '') and
418 (fileexists(IconFile)) then
419 begin
420 if(IconIndex <> -1) then
421 RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
422 '',Format('%s,%d',[IconFile,IconIndex]))
423 else
424 RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon',
425 '',IconFile);
426 end;
427 end;
428
429 // Systemsymbole aktualisieren
430 self.UpdateShell;
431
432 // Properties aktualisieren
433 if(Result) then
434 begin
435 FExtension := Extension;
436 FInternalName := strDummy;
437 end;
438end;
439
440function TFileTypeRegistration.UnregisterExtension(const Extension: string):
441 boolean;
442begin
443 Result := false;
444 if(FRegConnector = INVALID_HANDLE_VALUE) or
445 (Extension = '') or
446 (Extension[1] <> '.') then exit;
447
448 // die Endung entfernen
449 Result := (RegKeyExists(FRegConnector,Extension)) and
450 (RegDeleteWholeKey(FRegConnector,Extension));
451
452 // Systemsymbole aktualisieren
453 self.UpdateShell;
454end;
455
456function TFileTypeRegistration.UnregisterType(const Extension: string):
457 boolean;
458var
459 strDummy : string;
460begin
461 Result := false;
462 if(FRegConnector = INVALID_HANDLE_VALUE) or
463 (Extension = '') or
464 (Extension[1] <> '.') then exit;
465
466 // den internen Namen der Endung ermitteln
467 strDummy := self.GetInternalKey(Extension);
468
469 // die Endung entfernen (s. "UnregisterExtension"), ...
470 Result := (self.UnregisterExtension(Extension)) and
471 // ... & den internen Schlüssel löschen
472 (strDummy <> '') and
473 (RegKeyExists(FRegConnector,strDummy)) and
474 (RegDeleteWholeKey(FRegConnector,strDummy));
475
476 // Systemsymbole aktualisieren
477 self.UpdateShell;
478end;
479
480procedure TFileTypeRegistration.UpdateShell;
481begin
482 SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST,nil,nil);
483end;
484
485
486const
487 ShellKey = '%s\shell\%s';
488
489function TFileTypeRegistration.AddHandler(const HandlerVerb,
490 CommandLine: string; HandlerDescription: string = ''): boolean;
491begin
492 // Standardergebnis
493 Result := false;
494 if(FRegConnector = INVALID_HANDLE_VALUE) or
495 (FInternalName = '') or
496 (HandlerVerb = '') or
497 (CommandLine = '') then exit;
498
499 // der interne Schlüssel muss existieren
500 if(RegKeyExists(FRegConnector,FInternalName)) then
501 begin
502 // den Handler (= Verb) erzeugen
503 Result := RegWriteSubKeyVal(FRegConnector,
504 Format(ShellKey + '\command',[FInternalName,HandlerVerb]),
505 '',
506 CommandLine);
507
508 // ggf. Beschreibung für Handler setzen
509 if(HandlerDescription <> '') then
510 RegWriteSubKeyVal(FRegConnector,
511 Format(ShellKey,[FInternalName,HandlerVerb]),
512 '',
513 HandlerDescription);
514 end;
515
516 // interne Eigenschaft anpassen (für "SetDefaultHandler")
517 if(Result) then
518 FVerb := HandlerVerb;
519end;
520
521function TFileTypeRegistration.DeleteHandler(const HandlerVerb: string):
522 boolean;
523begin
524 // Standardergebnis
525 Result := false;
526 if(FRegConnector = INVALID_HANDLE_VALUE) or
527 (FInternalName = '') or
528 (HandlerVerb = '') then exit;
529
530 // Handlerschlüssel entfernen (sofern vorhanden)
531 Result :=
532 (RegKeyExists(FRegConnector,
533 Format(ShellKey,[FInternalName,HandlerVerb]))) and
534 (RegDeleteWholeKey(FRegConnector,
535 Format(ShellKey,[FInternalName,HandlerVerb])));
536end;
537
538function TFileTypeRegistration.SetDefaultHandler: boolean;
539begin
540 if(FInternalName <> '') and (FVerb <> '') then
541 Result := self.SetDefaultHandler(FVerb)
542 else
543 Result := false;
544end;
545
546function TFileTypeRegistration.SetDefaultHandler(const HandlerVerb: string):
547 boolean;
548begin
549 Result := false;
550 if(FRegConnector = INVALID_HANDLE_VALUE) or
551 (FInternalName = '') or
552 (HandlerVerb = '') then exit;
553
554 // interner Schlüssel muss existieren, ...
555 if(RegKeyExists(FRegConnector,FInternalName)) and
556 // ... & Handler muss existieren, ...
557 (RegKeyExists(FRegConnector,
558 Format(ShellKey,[FInternalName,HandlerVerb]))) then
559 begin
560 // ... dann den Handler als Standard eintragen
561 Result := RegWriteSubKeyVal(FRegConnector,FInternalName + '\shell',
562 '',HandlerVerb);
563 end;
564end;
565
566function TFileTypeRegistration.GetInternalKey(const Extension: string): string;
567begin
568 if(FRegConnector = INVALID_HANDLE_VALUE) or
569 (Extension = '') or
570 (Extension[1] <> '.') then exit;
571
572 // einen evtl. eingestellten internen Namen zurücksetzen
573 FInternalName := '';
574
575 // den Schlüssel der Dateiendung öffnen, ...
576 if(RegKeyExists(FRegConnector,Extension)) then
577 FInternalName := RegReadSubKeyStr(FRegConnector,Extension,'');
578
579 // ... als Funktionsergebnis zurückliefern
580 if(not RegKeyExists(FRegConnector,FInternalName)) then
581 FInternalName := '';
582
583 Result := FInternalName;
584end;
585
586
587function TFileTypeRegistration.AddNewFileSupport(const Extension: string):
588 boolean;
589var
590 Description : string;
591begin
592 Result := false;
593 if(FRegConnector = INVALID_HANDLE_VALUE) or
594 (Extension = '') or
595 (Extension[1] <> '.') then exit;
596
597 // interne Beschreibung des Typs ermitteln
598 if(self.GetInternalKey(Extension) <> '') then
599 Description := RegReadSubKeyStr(FRegConnector,FInternalName,'')
600 else
601 Description := '';
602
603 // die Beschreibung darf keine Leerzeichen enthalten, weil sie
604 // als Referenz für den neuen Dateinamen verwendet wird, ...
605 if(pos(#32,Description) > 0) or
606 // ... & sie darf auch nicht leer sein
607 (Description = '') then exit;
608
609 Result := (RegKeyExists(FRegConnector,Extension)) and
610 (RegWriteSubKeyVal(FRegConnector,Extension + '\ShellNew','NullFile',''));
611end;
612
613function TFileTypeRegistration.RemoveNewFileSupport(const Extension: string):
614 boolean;
615begin
616 Result := false;
617 if(FRegConnector = INVALID_HANDLE_VALUE) or
618 (Extension = '') or
619 (Extension[1] <> '.') then exit;
620
621 Result := (RegKeyExists(FRegConnector,Extension + '\ShellNew')) and
622 (RegDeleteWholeKey(FRegConnector,Extension + '\ShellNew'));
623end;
624
625end.
Note: See TracBrowser for help on using the repository browser.