Index: oup/current/ImportedStuff/FTypeReg.pas =================================================================== --- oup/current/ImportedStuff/FTypeReg.pas (revision 89) +++ oup/current/ImportedStuff/FTypeReg.pas (revision 89) @@ -0,0 +1,625 @@ +// ----------------------------------------------------------------------------- +// +// TFileTypeRegistration-Klasse (Win32-API) +// Copyright (c) 2004 Mathias Simmack +// +// ----------------------------------------------------------------------------- + +// -- Revision history --------------------------------------------------------- +// +// * erste Version +// +// ----------------------------------------------------------------------------- +unit FTypeReg; + +interface + +uses + Windows, ShlObj, SysUtils; + +type + TFileTypeRegistration = class + FRegConnector : HKEY; + FExtension, + FInternalName : string; + FVerb : string; + public + constructor Create; + destructor Destroy; override; + function RegisterType(const Extension, InternalName: string; + Description: string = ''; IconFile: string = ''; + IconIndex: integer = -1): boolean; + function UnregisterExtension(const Extension: string): boolean; + function UnregisterType(const Extension: string): boolean; + procedure UpdateShell; + function AddHandler(const HandlerVerb, CommandLine: string; + HandlerDescription: string = ''): boolean; overload; + function DeleteHandler(const HandlerVerb: string): boolean; + function SetDefaultHandler: boolean; overload; + function SetDefaultHandler(const HandlerVerb: string): boolean; overload; + function GetInternalKey(const Extension: string): string; + function AddNewFileSupport(const Extension: string): boolean; + function RemoveNewFileSupport(const Extension: string): boolean; + + property Extension: string read FExtension; + property InternalName: string read FInternalName; + property CurrentVerb: string read FVerb; + end; + + +implementation + +(* ***************************************************************************** + + Beispiel #1: Einen neuen Dateityp registrieren + ---------------------------------------------- + + ftr := TFileTypeRegistration.Create; + if(ftr <> nil) then + try + // die Dateiendung ".foo" registrieren, der interne Schlüssel + // lautet "FooFile", eine Beschreibung und eine Symboldatei + // sind ebenfalls angegeben + if(ftr.RegisterType('.foo','FooFile','FOO Description', + 'c:\folder\icon.ico')) then + begin + // fügt den Handler "open" hinzu und verknüpft ihn mit dem + // Programm "foo.exe" + ftr.AddHandler('open','"c:\folder\foo.exe" "%1"'); + + // setzt den zuletzt benutzten Handler ("open" in dem Fall) + // als Standard + ftr.SetDefaultHandler; + end; + + if(ftr.RegisterType('.foo','ThisIsNotTheFOOKey')) then + // Das ist kein Fehler! Obwohl hier der interne Name + // "ThisIsNotTheFOOKey" verwendet wird, benutzt die Funktion + // intern den bereits vorhandenen Schlüssel "FooFile" (s. oben). + begin + // zwei neue Handler werden registriert, ... + ftr.AddHandler('print','"c:\folder\foo.exe" /p "%1"'); + ftr.AddHandler('edit','notepad.exe "%1"'); + + // ... & dank der überladenen Funktion "SetDefaultHandler" + // kann diesmal auch "print" als Standardhandler gesetzt + // werden + ftr.SetDefaultHandler('print'); + end; + finally + ftr.Free; + end; + + + Beispiel #2: Einen neuen Typ mit einem vorhandenen Schlüssel + verknüpfen + ------------------------------------------------------------ + + Das Beispiel registriert die Endung ".foo" auf die gleiche + Weise wie Textdateien (.txt). Es wird einfach der interne + Schlüsselname ermittelt und für die Endung ".foo" gesetzt + + ftr := TFileTypeRegistration.Create; + if(ftr <> nil) then + try + strInternalTextFileKey := ftr.GetInternalKey('.txt'); + if(strInternalTextFileKey <> '') then + ftr.RegisterType('.foo',strInternalTextFileKey); + finally + ftr.Free; + end; + + + Beispiel #3: Einen Handler entfernen + ------------------------------------ + + ftr := TFileTypeRegistration.Create; + if(ftr <> nil) then + try + // den internen Schlüsselnamen des Typs ".foo" ermitteln, ... + if(ftr.GetInternalKey('.foo') <> '') then + // ... wobei das Ergebnis in dem Fall unwichtig ist, weil + // intern auch die Eigenschaft "FInternalName" gesetzt + // wird + begin + // den "print"-Handler entfernen, ... + ftr.DeleteHandler('print'); + + // ... & den Standardhandler aktualisieren + ftr.SetDefaultHandler('open'); + end; + finally + ftr.Free; + end; + + + Beispiel #4: Nur eine Dateiendung entfernen + ------------------------------------------- + + In diesem Fall wird lediglich die Endung ".foo" entfernt. Der + evtl. vorhandene interne Schlüssel bleibt bestehen. Das ist + für das Beispiel #2 nützlich, wenn die Endung ".foo" entfernt + werden soll, intern aber mit den Textdateien verlinkt ist, die + ja im Normalfall nicht entfernt werden dürfen/sollten. + + ftr.UnregisterExtension('.foo'); + + + Beispiel #5: Den kompletten Dateityp entfernen + ---------------------------------------------- + + Dieses Beispiel entfernt dagegen den kompletten Dateityp, + inkl. des evtl. vorhandenen internen Schlüssels (vgl. mit + Beispiel #4). + + ftr.UnregisterType('.foo'); + + Bezogen auf Beispiel #2 wäre das die fatale Lösung, weil dadurch + zwar die Endung ".foo" deregistriert wird, gleichzeitig wird + aber auch der intern verwendete Schlüssel der Textdateien + gelöscht. + + ALSO, VORSICHT!!! + +***************************************************************************** *) + + +// +// Admin-Rechte sind erforderlich (Funktion von NicoDE) +// +//{$INCLUDE IsAdmin.inc} +function GetAdminSid: PSID; +const + // bekannte SIDs ... (WinNT.h) + SECURITYNTAUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)); + // bekannte RIDs ... (WinNT.h) + SECURITYBUILTINDOMAINRID: DWORD = $00000020; + DOMAINALIASRIDADMINS: DWORD = $00000220; +begin + Result := nil; + AllocateAndInitializeSid(SECURITYNTAUTHORITY, 2, SECURITYBUILTINDOMAINRID, + DOMAINALIASRIDADMINS, 0, 0, 0, 0, 0, 0, Result); +end; + +function IsAdmin: LongBool; +var + TokenHandle : THandle; + ReturnLength : DWORD; + TokenInformation : PTokenGroups; + AdminSid : PSID; + Loop : Integer; + wv : TOSVersionInfo; +begin + wv.dwOSVersionInfoSize := sizeof(TOSversionInfo); + GetVersionEx(wv); + + Result := (wv.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS); + + if(wv.dwPlatformId = VER_PLATFORM_WIN32_NT) then + begin + TokenHandle := 0; + if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle) then + try + ReturnLength := 0; + GetTokenInformation(TokenHandle, TokenGroups, nil, 0, ReturnLength); + TokenInformation := GetMemory(ReturnLength); + if Assigned(TokenInformation) then + try + if GetTokenInformation(TokenHandle, TokenGroups, + TokenInformation, ReturnLength, ReturnLength) then + begin + AdminSid := GetAdminSid; + for Loop := 0 to TokenInformation^.GroupCount - 1 do + begin + if EqualSid(TokenInformation^.Groups[Loop].Sid, AdminSid) then + begin + Result := True; + break; + end; + end; + FreeSid(AdminSid); + end; + finally + FreeMemory(TokenInformation); + end; + finally + CloseHandle(TokenHandle); + end; + end; +end; + +function WVersion: string; +var + OSInfo: TOSVersionInfo; +begin + Result := '3X'; + OSInfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO); + GetVersionEx(OSInfo); + case OSInfo.dwPlatformID of + VER_PLATFORM_WIN32S: begin + Result := '3X'; + Exit; + end; + VER_PLATFORM_WIN32_WINDOWS: begin + Result := '9X'; + Exit; + end; + VER_PLATFORM_WIN32_NT: begin + Result := 'NT'; + Exit; + end; + end; //case +end; + + +// ----------------------------------------------------------------------------- +// +// Registry +// +// ----------------------------------------------------------------------------- + +function RegWriteSubKeyVal(const parent: HKEY; SubKeyName: string; + ValueName, Value: string): boolean; +var + tmp : HKEY; +begin + Result := false; + if(parent = INVALID_HANDLE_VALUE) or + (SubKeyName = '') then exit; + + if(RegCreateKeyEx(parent,pchar(SubKeyName),0,nil,0,KEY_READ or KEY_WRITE, + nil,tmp,nil) = ERROR_SUCCESS) then + try + Result := (RegSetValueEx(tmp,pchar(ValueName),0,REG_SZ,pchar(Value), + length(Value) + 1) = ERROR_SUCCESS); + finally + RegCloseKey(tmp); + end; +end; + +function RegReadSubKeyStr(const parent: HKEY; SubKeyName: string; + ValueName: string): string; +var + tmp : HKEY; + lpData, + dwLen : dword; +begin + Result := ''; + if(parent = INVALID_HANDLE_VALUE) or + (SubKeyName = '') then exit; + + if(RegOpenKeyEx(parent,pchar(SubKeyName),0,KEY_READ, + tmp) = ERROR_SUCCESS) then + try + lpData := REG_NONE; + dwLen := 0; + if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData,nil, + @dwLen) = ERROR_SUCCESS) and + (lpData in[REG_SZ,REG_EXPAND_SZ]) and + (dwLen > 0) then + begin + SetLength(Result,dwLen); + + if(RegQueryValueEx(tmp,pchar(ValueName),nil,@lpData, + @Result[1],@dwLen) = ERROR_SUCCESS) then + SetLength(Result,dwLen - 1) + else + Result := ''; + end; + finally + RegCloseKey(tmp); + end; +end; + +function RegKeyExists(const parent: HKEY; KeyName: string): boolean; +var + tmp : HKEY; +begin + Result := (RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,tmp) = + ERROR_SUCCESS); + if(Result) then RegCloseKey(tmp); +end; + +function RegDeleteWholeKey(parent: HKEY; KeyName: string): boolean; +var + reg : HKEY; + dwSubkeys : dword; + dwLen : dword; + i : integer; + buf : array[0..MAX_PATH]of char; +begin + if(RegOpenKeyEx(parent,pchar(KeyName),0,KEY_READ,reg) = ERROR_SUCCESS) then + try + if(RegQueryInfoKey(reg,nil,nil,nil,@dwSubKeys,nil, + nil,nil,nil,nil,nil,nil) = ERROR_SUCCESS) and + (dwSubKeys > 0) then + for i := 0 to dwSubKeys - 1 do begin + ZeroMemory(@buf,sizeof(buf)); + dwLen := MAX_PATH; + + if(RegEnumKeyEx(reg,i,buf,dwLen,nil,nil,nil,nil) = ERROR_SUCCESS) and + (dwLen > 0) then + RegDeleteWholeKey(reg,buf); + end; + finally + RegCloseKey(reg); + end; + + Result := (RegDeleteKey(parent,pchar(KeyName)) = ERROR_SUCCESS); +end; + + +// ----------------------------------------------------------------------------- +// +// TFileTypeRegistration-Klasse +// +// ----------------------------------------------------------------------------- + +constructor TFileTypeRegistration.Create; +var + key: HKEY; + sub: PChar; +begin + FExtension := ''; + FInternalName := ''; + FVerb := ''; + + // Zugriff auf die Registry, & HKEY_CLASSES_ROOT + // als Root setzen + if(WVersion='9X') or IsAdmin then begin + key:=HKEY_CLASSES_ROOT; + sub:=nil; + end else begin + key:=HKEY_CURRENT_USER; + sub:=PChar('SOFTWARE\Classes'); + end; + + if RegOpenKeyEx(key,sub,0,KEY_ALL_ACCESS, FRegConnector) <> ERROR_SUCCESS then + FRegConnector := INVALID_HANDLE_VALUE; +end; + +destructor TFileTypeRegistration.Destroy; +begin + if(FRegConnector <> INVALID_HANDLE_VALUE) then + RegCloseKey(FRegConnector); +end; + +function TFileTypeRegistration.RegisterType(const Extension, + InternalName: string; Description: string = ''; IconFile: string = ''; + IconIndex: integer = -1): boolean; +var + strDummy : string; +begin + // Standardergebnis + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + // ist dieser Typ evtl. schon registriert? + strDummy := self.GetInternalKey(Extension); + + // Nein. :o) + if(strDummy = '') then strDummy := InternalName; + + // den Schlüssel mit der Dateiendung anlegen oder aktualisieren + Result := RegWriteSubKeyVal(FRegConnector,Extension,'',strDummy); + if(not Result) then exit; + + // den internen Schlüssel öffnen + if(Result) then + begin + // Beschreibung anlegen + if(Description <> '') then + RegWriteSubKeyVal(FRegConnector,strDummy,'',Description); + + // Symbol zuweisen (Datei muss existieren!) + if(IconFile <> '') and + (fileexists(IconFile)) then + begin + if(IconIndex <> -1) then + RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon', + '',Format('%s,%d',[IconFile,IconIndex])) + else + RegWriteSubKeyVal(FRegConnector,strDummy + '\DefaultIcon', + '',IconFile); + end; + end; + + // Systemsymbole aktualisieren + self.UpdateShell; + + // Properties aktualisieren + if(Result) then + begin + FExtension := Extension; + FInternalName := strDummy; + end; +end; + +function TFileTypeRegistration.UnregisterExtension(const Extension: string): + boolean; +begin + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + // die Endung entfernen + Result := (RegKeyExists(FRegConnector,Extension)) and + (RegDeleteWholeKey(FRegConnector,Extension)); + + // Systemsymbole aktualisieren + self.UpdateShell; +end; + +function TFileTypeRegistration.UnregisterType(const Extension: string): + boolean; +var + strDummy : string; +begin + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + // den internen Namen der Endung ermitteln + strDummy := self.GetInternalKey(Extension); + + // die Endung entfernen (s. "UnregisterExtension"), ... + Result := (self.UnregisterExtension(Extension)) and + // ... & den internen Schlüssel löschen + (strDummy <> '') and + (RegKeyExists(FRegConnector,strDummy)) and + (RegDeleteWholeKey(FRegConnector,strDummy)); + + // Systemsymbole aktualisieren + self.UpdateShell; +end; + +procedure TFileTypeRegistration.UpdateShell; +begin + SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST,nil,nil); +end; + + +const + ShellKey = '%s\shell\%s'; + +function TFileTypeRegistration.AddHandler(const HandlerVerb, + CommandLine: string; HandlerDescription: string = ''): boolean; +begin + // Standardergebnis + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (FInternalName = '') or + (HandlerVerb = '') or + (CommandLine = '') then exit; + + // der interne Schlüssel muss existieren + if(RegKeyExists(FRegConnector,FInternalName)) then + begin + // den Handler (= Verb) erzeugen + Result := RegWriteSubKeyVal(FRegConnector, + Format(ShellKey + '\command',[FInternalName,HandlerVerb]), + '', + CommandLine); + + // ggf. Beschreibung für Handler setzen + if(HandlerDescription <> '') then + RegWriteSubKeyVal(FRegConnector, + Format(ShellKey,[FInternalName,HandlerVerb]), + '', + HandlerDescription); + end; + + // interne Eigenschaft anpassen (für "SetDefaultHandler") + if(Result) then + FVerb := HandlerVerb; +end; + +function TFileTypeRegistration.DeleteHandler(const HandlerVerb: string): + boolean; +begin + // Standardergebnis + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (FInternalName = '') or + (HandlerVerb = '') then exit; + + // Handlerschlüssel entfernen (sofern vorhanden) + Result := + (RegKeyExists(FRegConnector, + Format(ShellKey,[FInternalName,HandlerVerb]))) and + (RegDeleteWholeKey(FRegConnector, + Format(ShellKey,[FInternalName,HandlerVerb]))); +end; + +function TFileTypeRegistration.SetDefaultHandler: boolean; +begin + if(FInternalName <> '') and (FVerb <> '') then + Result := self.SetDefaultHandler(FVerb) + else + Result := false; +end; + +function TFileTypeRegistration.SetDefaultHandler(const HandlerVerb: string): + boolean; +begin + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (FInternalName = '') or + (HandlerVerb = '') then exit; + + // interner Schlüssel muss existieren, ... + if(RegKeyExists(FRegConnector,FInternalName)) and + // ... & Handler muss existieren, ... + (RegKeyExists(FRegConnector, + Format(ShellKey,[FInternalName,HandlerVerb]))) then + begin + // ... dann den Handler als Standard eintragen + Result := RegWriteSubKeyVal(FRegConnector,FInternalName + '\shell', + '',HandlerVerb); + end; +end; + +function TFileTypeRegistration.GetInternalKey(const Extension: string): string; +begin + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + // einen evtl. eingestellten internen Namen zurücksetzen + FInternalName := ''; + + // den Schlüssel der Dateiendung öffnen, ... + if(RegKeyExists(FRegConnector,Extension)) then + FInternalName := RegReadSubKeyStr(FRegConnector,Extension,''); + + // ... als Funktionsergebnis zurückliefern + if(not RegKeyExists(FRegConnector,FInternalName)) then + FInternalName := ''; + + Result := FInternalName; +end; + + +function TFileTypeRegistration.AddNewFileSupport(const Extension: string): + boolean; +var + Description : string; +begin + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + // interne Beschreibung des Typs ermitteln + if(self.GetInternalKey(Extension) <> '') then + Description := RegReadSubKeyStr(FRegConnector,FInternalName,'') + else + Description := ''; + + // die Beschreibung darf keine Leerzeichen enthalten, weil sie + // als Referenz für den neuen Dateinamen verwendet wird, ... + if(pos(#32,Description) > 0) or + // ... & sie darf auch nicht leer sein + (Description = '') then exit; + + Result := (RegKeyExists(FRegConnector,Extension)) and + (RegWriteSubKeyVal(FRegConnector,Extension + '\ShellNew','NullFile','')); +end; + +function TFileTypeRegistration.RemoveNewFileSupport(const Extension: string): + boolean; +begin + Result := false; + if(FRegConnector = INVALID_HANDLE_VALUE) or + (Extension = '') or + (Extension[1] <> '.') then exit; + + Result := (RegKeyExists(FRegConnector,Extension + '\ShellNew')) and + (RegDeleteWholeKey(FRegConnector,Extension + '\ShellNew')); +end; + +end.