jclregistry.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclRegistry.pas.                                                            }
{                                                                                                  }
{ The Initial Developers of the Original Code are John C Molyneux, Marcel van Brakel and           }
{ Charlie Calvert. Portions created by these individuals are Copyright (C) of these individuals.   }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Marcel van Brakel                                                                              }
{   Stephane Fillon                                                                                }
{   Eric S.Fisher                                                                                  }
{   Peter Friese                                                                                   }
{   Andreas Hausladen (ahuser)                                                                     }
{   Manlio Laschena (manlio)                                                                       }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Olivier Sannier (obones)                                                                       }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Contains various utility routines to read and write registry values. Using these routines        }
{ prevents you from having to instantiate temporary TRegistry objects and since the routines       }
{ directly call the registry API they do not suffer from the resource overhead as TRegistry does.  }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file

unit JclRegistry;

{$I jcl.inc}

interface

uses
  Windows, Classes,
  JclBase, JclStrings, JclWideStrings;

type
  DelphiHKEY = Longword;
  {$HPPEMIT '// BCB users must typecast the HKEY values to DelphiHKEY or use the HK-values below.'}

  TExecKind = (ekMachineRun, ekMachineRunOnce, ekUserRun, ekUserRunOnce,
    ekServiceRun, ekServiceRunOnce);

  EJclRegistryError = class(EJclError);

{$IFNDEF FPC}
// (rom) from JclMiscel.pas, now put to good use for BCB
const
  HKCR = DelphiHKEY(HKEY_CLASSES_ROOT);
  HKCU = DelphiHKEY(HKEY_CURRENT_USER);
  HKLM = DelphiHKEY(HKEY_LOCAL_MACHINE);
  HKUS = DelphiHKEY(HKEY_USERS);
  HKPD = DelphiHKEY(HKEY_PERFORMANCE_DATA);
  HKCC = DelphiHKEY(HKEY_CURRENT_CONFIG);
  HKDD = DelphiHKEY(HKEY_DYN_DATA);
{$ENDIF ~FPC}

function RegCreateKey(const RootKey: DelphiHKEY; const Key: string): Longint; overload;
function RegCreateKey(const RootKey: DelphiHKEY; const Key, Value: string): Longint; overload;
function RegDeleteEntry(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;
function RegDeleteKeyTree(const RootKey: DelphiHKEY; const Key: string): Boolean;

function RegGetDataSize(const RootKey: DelphiHKEY; const Key, Name: string;
  out DataSize: Cardinal): Boolean;
function RegGetDataType(const RootKey: DelphiHKEY; const Key, Name: string;
  out DataType: Cardinal): Boolean;
function RegReadBool(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;
function RegReadBoolDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Boolean): Boolean;
function RegReadInteger(const RootKey: DelphiHKEY; const Key, Name: string): Integer;
function RegReadIntegerDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Integer): Integer;
function RegReadCardinal(const RootKey: DelphiHKEY; const Key, Name: string): Cardinal;
function RegReadCardinalDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Cardinal): Cardinal;
function RegReadDWORD(const RootKey: DelphiHKEY; const Key, Name: string): DWORD;
function RegReadDWORDDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: DWORD): DWORD;
function RegReadInt64(const RootKey: DelphiHKEY; const Key, Name: string): Int64;
function RegReadInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: Int64): Int64;
function RegReadUInt64(const RootKey: DelphiHKEY; const Key, Name: string): UInt64;
function RegReadUInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: UInt64): UInt64;
function RegReadSingle(const RootKey: DelphiHKEY; const Key, Name: string): Single;
function RegReadSingleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Single): Single;
function RegReadDouble(const RootKey: DelphiHKEY; const Key, Name: string): Double;
function RegReadDoubleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Double): Double;
function RegReadExtended(const RootKey: DelphiHKEY; const Key, Name: string): Extended;
function RegReadExtendedDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Extended): Extended;

function RegReadString(const RootKey: DelphiHKEY; const Key, Name: string): string;
function RegReadStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: string): string;
function RegReadAnsiString(const RootKey: DelphiHKEY; const Key, Name: AnsiString): AnsiString;
function RegReadAnsiStringDef(const RootKey: DelphiHKEY; const Key, Name: AnsiString; Def: AnsiString): AnsiString;
function RegReadWideString(const RootKey: DelphiHKEY; const Key, Name: string): WideString;
function RegReadWideStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: WideString): WideString;

procedure RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TStrings); overload;
function RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PMultiSz; overload;
procedure RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TStrings); overload;
function RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: PMultiSz): PMultiSz; overload;

procedure RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TWideStrings); overload;
function RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PWideMultiSz; overload;
procedure RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TWideStrings); overload;
function RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: PWideMultiSz): PWideMultiSz; overload;

function RegReadBinary(const RootKey: DelphiHKEY; const Key, Name: string; var Value; const ValueSize: Cardinal): Cardinal;
function RegReadBinaryDef(const RootKey: DelphiHKEY; const Key, Name: string;
  var Value; const ValueSize: Cardinal; const Def: Byte): Cardinal;

procedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; Value: Boolean); overload;
procedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Boolean); overload;
procedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; Value: Integer); overload;
procedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Integer); overload;
procedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; Value: Cardinal); overload;
procedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Cardinal); overload;
procedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; Value: DWORD); overload;
procedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: DWORD); overload;
procedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: Int64); overload;
procedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Int64); overload;
procedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: UInt64); overload;
procedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: UInt64); overload;
procedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; Value: Single); overload;
procedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Single); overload;
procedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; Value: Double); overload;
procedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Double); overload;
procedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; Value: Extended); overload;
procedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Extended); overload;

procedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name, Value: string); overload;
procedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: string); overload;
procedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name, Value: AnsiString); overload;
procedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name: AnsiString; DataType: Cardinal; Value: AnsiString); overload;
procedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; Value: WideString); overload;
procedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: WideString); overload;

procedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PMultiSz); overload;
procedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TStrings); overload;
procedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: PMultiSz); overload;
procedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; const Value: TStrings); overload;
procedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PWideMultiSz); overload;
procedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TWideStrings); overload;
procedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: PWideMultiSz); overload;
procedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; const Value: TWideStrings); overload;

procedure RegWriteBinary(const RootKey: DelphiHKEY; const Key, Name: string; const Value; const ValueSize: Cardinal);

function RegGetValueNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;
function RegGetKeyNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;
function RegHasSubKeys(const RootKey: DelphiHKEY; const Key: string): Boolean;

function AllowRegKeyForEveryone(const RootKey: DelphiHKEY; Path: string): Boolean;
{
From: Jean-Fabien Connault [cycocrew att worldnet dott fr]
Descr: Test whether a registry key exists as a subkey of RootKey
Used test cases:
procedure TForm1.Button1Click(Sender: TObject);
var
  RegKey: HKEY;
begin
  if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software', 0, KEY_READ, RegKey) = ERROR_SUCCESS then
  begin
    Assert(not RegKeyExists(RegKey, 'Microsoft\_Windows'));
    RegCloseKey(RegKey);
  end;
  if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software', 0, KEY_READ, RegKey) = ERROR_SUCCESS then
  begin
    Assert(RegKeyExists(RegKey, 'Microsoft\Windows'));;
    RegCloseKey(RegKey);
  end;
  Assert(RegKeyExists(HKEY_CURRENT_USER, ''));
  Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software'));
  Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software\Microsoft'));
  Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software\Microsoft\Windows'));
  Assert(RegKeyExists(HKEY_CURRENT_USER, '\Software\Microsoft\Windows'));
  Assert(not RegKeyExists(HKEY_CURRENT_USER, '\Software\Microsoft2\Windows'));
end;
}
function RegKeyExists(const RootKey: DelphiHKEY; const Key: string): Boolean;

function UnregisterAutoExec(ExecKind: TExecKind; const Name: string): Boolean;
function RegisterAutoExec(ExecKind: TExecKind; const Name, Cmdline: string): Boolean;

function RegSaveList(const RootKey: DelphiHKEY; const Key: string; const ListName: string;
  const Items: TStrings): Boolean;
function RegLoadList(const RootKey: DelphiHKEY; const Key: string; const ListName: string;
  const SaveTo: TStrings): Boolean;
function RegDelList(const RootKey: DelphiHKEY; const Key: string; const ListName: string): Boolean;

implementation

uses
  SysUtils,
  {$IFDEF FPC}
  JwaAccCtrl,
  {$ELSE}
  AccCtrl,
  {$ENDIF FPC}
  JclResources, JclSysUtils, JclWin32;

type
  TRegKind = REG_NONE..REG_QWORD;
  TRegKinds = set of TRegKind;

const
  cItems = 'Items';
  cRegBinKinds = [REG_SZ..REG_QWORD];  // all types

//=== Internal helper routines ===============================================

procedure ReadError(const Key: string);
begin
  raise EJclRegistryError.CreateResFmt(@RsUnableToOpenKeyRead, [Key]);
end;

procedure WriteError(const Key: string);
begin
  raise EJclRegistryError.CreateResFmt(@RsUnableToOpenKeyWrite, [Key]);
end;

procedure ValueError(const Key, Name: string);
begin
  raise EJclRegistryError.CreateResFmt(@RsUnableToAccessValue, [Key, Name]);
end;

procedure DataError(const Key, Name: string);
begin
  raise EJclRegistryError.CreateResFmt(@RsWrongDataType, [Key, Name]);
end;

function GetKeyAndPath(ExecKind: TExecKind; var Key: HKEY; out RegPath: string): Boolean;
begin
  Result := False;
  if (ExecKind in [ekServiceRun, ekServiceRunOnce]) and (Win32Platform = VER_PLATFORM_WIN32_NT) then
    Exit;
  if ExecKind in [ekMachineRun, ekMachineRunOnce, ekServiceRun, ekServiceRunOnce] then
    Key := HKEY_LOCAL_MACHINE
  else
    Key := HKEY_CURRENT_USER;
  RegPath := 'Software\Microsoft\Windows\CurrentVersion\';
  case ExecKind of
    ekMachineRun, ekUserRun:
      RegPath := RegPath + 'Run';
    ekMachineRunOnce, ekUserRunOnce:
      RegPath := RegPath + 'RunOnce';
    ekServiceRun:
      RegPath := RegPath + 'RunServices';
    ekServiceRunOnce:
      RegPath := RegPath + 'RunServicesOnce';
  end;
  Result := True;
end;

function RelativeKey(const RootKey: DelphiHKEY; Key: PChar): PChar;
type
  TRootKey = record
    Key: DelphiHKEY;
    Name: PChar;
  end;
const
  RootKeys: array [0..13] of TRootKey =
   (
    (Key: HKCR; Name: 'HKEY_CLASSES_ROOT\'),
    (Key: HKCU; Name: 'HKEY_CURRENT_USER\'),
    (Key: HKLM; Name: 'HKEY_LOCAL_MACHINE\'),
    (Key: HKUS; Name: 'HKEY_USERS\'),
    (Key: HKPD; Name: 'HKEY_PERFORMANCE_DATA\'),
    (Key: HKCC; Name: 'HKEY_CURRENT_CONFIG\'),
    (Key: HKDD; Name: 'HKEY_DYN_DATA\'),
    (Key: HKCR; Name: 'HKCR\'),
    (Key: HKCU; Name: 'HKCU\'),
    (Key: HKLM; Name: 'HKLM\'),
    (Key: HKUS; Name: 'HKUS\'),
    (Key: HKPD; Name: 'HKPD\'),
    (Key: HKCC; Name: 'HKCC\'),
    (Key: HKDD; Name: 'HKDD\')
   );
var
  I: Integer;
begin
  Result := Key;
  if Result^ = '\' then
    Inc(Result);
  for I := Low(RootKeys) to High(RootKeys) do
    if StrPos(Key, RootKeys[I].Name) = Result then
    begin
      if RootKey <> RootKeys[I].Key then
        raise EJclRegistryError.CreateResFmt(@RsInconsistentPath, [Key])
      else
        Inc(Result, StrLen(RootKeys[I].Name));
      Break;
    end;
end;

function InternalRegOpenKeyEx(Key: HKEY; SubKey: PChar;
  ulOptions: DWORD; samDesired: REGSAM; var RegKey: HKEY): Longint;
var
  WideKey: WideString;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    WideKey := RelativeKey(Key, SubKey);
    Result := RegOpenKeyExW(Key, PWideChar(WideKey), ulOptions, samDesired, RegKey);
  end
  else
    Result := RegOpenKeyExA(Key, RelativeKey(Key, SubKey), ulOptions, samDesired, RegKey);
end;

function InternalRegQueryValueEx(Key: HKEY; ValueName: PChar;
  lpReserved: Pointer; lpType: PDWORD; lpData: PByte; lpcbData: PDWORD): Longint;
var
  WideName: WideString;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    WideName := ValueName;
    Result := RegQueryValueExW(Key, PWideChar(WideName), lpReserved, lpType, lpData, lpcbData);
  end
  else
    Result := RegQueryValueExA(Key, ValueName, lpReserved, lpType, lpData, lpcbData);
end;

function InternalRegSetValueEx(Key: HKEY; ValueName: PChar;
  Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; stdcall;
var
  WideName: WideString;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    WideName := ValueName;
    Result := RegSetValueExW(Key, PWideChar(WideName), Reserved, dwType, lpData, cbData);
  end
  else
    Result := RegSetValueExA(Key, PChar(ValueName), Reserved, dwType, lpData, cbData);
end;

procedure InternalGetData(const RootKey: DelphiHKEY; const Key, Name: string;
  RegKinds: TRegKinds; ExpectedSize: DWORD;
  out DataType: DWORD; Data: Pointer; out DataSize: DWORD);
var
  RegKey: HKEY;
begin
  DataType := REG_NONE;
  DataSize := 0;
  if InternalRegOpenKeyEx(RootKey, PChar(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then
    try
      if InternalRegQueryValueEx(RegKey, PChar(Name), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then
      begin
        if not (DataType in RegKinds) or (DataSize > ExpectedSize) then
          DataError(Key, Name);
        if InternalRegQueryValueEx(RegKey, PChar(Name), nil, nil, Data, @DataSize) <> ERROR_SUCCESS then
          ValueError(Key, Name);
      end
      else
        ValueError(Key, Name);
    finally
      RegCloseKey(RegKey);
    end
  else
    ReadError(Key);
end;