source: oup/current/FTypeReg.pas @ 46

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