untRegistry by ErazerZ

posted 28 Sep 2010, 09:44 by Delphi Basics   [ updated 28 Sep 2010, 09:53 ]
{
  Unit Registry by ErazerZ
  19. Februar 2006

  Requires: untUtils (by ErazerZ)
}

unit untRegistry;

interface

uses Windows, untUtils;

function HKEYToStr(hkKey: HKEY): String;
function StrToHKEY(sKey: String): HKEY;
function _regCreateKey(hkKey: HKEY; lpSubKey: PChar): Boolean;
function _regDeleteKey(hkKey: HKEY; lpSubKey: PChar): Boolean;
function _regCreateValue(hkKey: HKEY; lpSubKey, lpValueName: PChar; lpType: DWORD): Boolean;
function _regValueExists(hkKey: HKEY; lpSubKey, lpValueName: PChar): Boolean;
function _regRenameValue(hkKey: HKEY; lpSubKey, lpValueName, lpNewValueName: PChar): Boolean;
function _regDeleteValue(hkKey: HKEY; lpSubKey, lpValueName: PChar): Boolean;
function _regSetValue(hkKey: HKEY; lpSubKey, lpValueName: PChar; NewValue: Pointer; cbLength: DWORD; lpType: DWORD = DWORD(-1)): Boolean;
function _regMultiString(hkKey: HKEY; lpSubKey, lpValueName: PChar): String;
function _regQueryValue(var phkResult: HKEY; lpValueName: PChar; lpType: DWORD = REG_NONE): String;
function _regQueryValueType(var phkResult: HKEY; lpValueName: PChar): String;
function _regEnumKeys(hkKey: HKEY; lpSubKey: PChar): String;
function _regEnumValues(hkKey: HKEY; lpSubKey: PChar): String;

implementation

type
  PByteArray = ^TByteArray;
  TByteArray = array[0..32767] of Byte;

function HKEYToStr(hkKey: HKEY): String;
begin
  case hkKey of
    HKEY_CLASSES_ROOT: Result := 'HKEY_CLASSES_ROOT';
    HKEY_CURRENT_USER: Result := 'HKEY_CURRENT_USER';
    HKEY_LOCAL_MACHINE: Result := 'HKEY_LOCAL_MACHINE';
    HKEY_USERS: Result := 'HKEY_USERS';
    HKEY_CURRENT_CONFIG: Result := 'HKEY_CURRENT_CONFIG';
  end;
end;

function StrToHKEY(sKey: String): HKEY;
begin
  Result := DWORD(-1);
  if sKey = '' then Exit;
  sKey := CharUpper(PChar(sKey));
  if sKey = 'HKEY_CLASSES_ROOT' then
    Result := HKEY_CLASSES_ROOT
  else if sKey = 'HKEY_CURRENT_USER' then
    Result := HKEY_CURRENT_USER
  else if sKey = 'HKEY_LOCAL_MACHINE' then
    Result := HKEY_LOCAL_MACHINE
  else if sKey = 'HKEY_USERS' then
    Result := HKEY_USERS
  else if sKey = 'HKEY_CURRENT_CONFIG' then
    Result := HKEY_CURRENT_CONFIG
end;

function _regCreateKey(hkKey: HKEY; lpSubKey: PChar): Boolean;
var
  phkResult: HKEY;
begin
  Result := RegCreateKey(hkKey, lpSubKey, phkResult) = ERROR_SUCCESS;
  RegCloseKey(phkResult);
end;

function _regDeleteKey(hkKey: HKEY; lpSubKey: PChar): Boolean;
begin
  Result := RegDeleteKey(hkKey, lpSubKey) = ERROR_SUCCESS;
end;

function _regCreateValue(hkKey: HKEY; lpSubKey, lpValueName: PChar; lpType: DWORD): Boolean;
var
  phkResult: HKEY;
begin
  Result := False;
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ or KEY_SET_VALUE, phkResult) = ERROR_SUCCESS then
  begin
    Result := RegSetValueEx(phkResult, lpValueName, 0, lpType, nil, 0) = ERROR_SUCCESS;
    RegCloseKey(phkResult);
  end;
end;

function _regValueExists(hkKey: HKEY; lpSubKey, lpValueName: PChar): Boolean;
var
  phkResult: HKEY;
begin
  Result := False;
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ, phkResult) = ERROR_SUCCESS then
  begin
    Result := RegQueryValueEx(phkResult, lpValueName, nil, nil, nil, nil) = ERROR_SUCCESS;
    RegCloseKey(phkResult);
  end;
end;

function _regRenameValue(hkKey: HKEY; lpSubKey, lpValueName, lpNewValueName: PChar): Boolean;
var
  phkResult: HKEY;
  lpData: Pointer;
  lpcbData, lpType: DWORD;
begin
  Result := False;
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ or KEY_SET_VALUE, phkResult) = ERROR_SUCCESS then
  begin
    if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, nil, @lpcbData) = ERROR_SUCCESS then
    begin
      GetMem(lpData, lpcbData);
      if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, lpData, @lpcbData) = ERROR_SUCCESS then
        if RegSetValueEx(phkResult, lpNewValueName, 0, lpType, lpData, lpcbData) = ERROR_SUCCESS then
          Result := RegDeleteValue(phkResult, lpValueName) = ERROR_SUCCESS;
      FreeMem(lpData, lpcbData);
    end;
    RegCloseKey(phkResult);
  end;
end;

function _regDeleteValue(hkKey: HKEY; lpSubKey, lpValueName: PChar): Boolean;
var
  phkResult: HKEY;
begin
  Result := False;
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_SET_VALUE, phkResult) = ERROR_SUCCESS then
  begin
    Result := RegDeleteValue(phkResult, lpValueName) = ERROR_SUCCESS;
    RegCloseKey(phkResult);
  end;
end;

function _regSetValue(hkKey: HKEY; lpSubKey, lpValueName: PChar; NewValue: Pointer; cbLength: DWORD; lpType: DWORD = DWORD(-1)): Boolean;
  function __regSetValue(hhkKey: HKEY; llpType: DWORD): Boolean;
  begin
    Result := False;
    if llpType = REG_DWORD then
      Result := RegSetValueEx(hhkKey, lpValueName, 0, llpType, NewValue, sizeof(DWORD)) = ERROR_SUCCESS
    else
    if (llpType = REG_SZ) or (llpType = REG_EXPAND_SZ) or (llpType = REG_MULTI_SZ) or (llpType = REG_BINARY) then
      Result := RegSetValueEx(hhkKey, lpValueName, 0, llpType, NewValue, cbLength) = ERROR_SUCCESS
  end;
var
  phkResult: HKEY;
begin
  Result := False;
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ or KEY_SET_VALUE, phkResult) = ERROR_SUCCESS then
  begin
    if lpType = DWORD(-1) then
    begin
      if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, nil, nil) = ERROR_SUCCESS then
        Result := __regSetValue(phkResult, lpType)
      else
        Result := __regSetValue(phkResult, REG_SZ);
    end else
      Result := __regSetValue(phkResult, lpType);
    RegCloseKey(phkResult);
  end;
end;

function _regMultiString(hkKey: HKEY; lpSubKey, lpValueName: PChar): String;
var
  phkResult: HKEY;
  lpData: Pointer;
  lpcbData, lpType: DWORD;
begin
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ, phkResult) = ERROR_SUCCESS then
  begin
    if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, nil, @lpcbData) = ERROR_SUCCESS then
    begin
      GetMem(lpData, lpcbData);
      if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, lpData, @lpcbData) = ERROR_SUCCESS then
      begin
        Dec(lpcbData);
        SetLength(Result, lpcbData);
        CopyMemory(@Result[1], lpData, lpcbData);
        ReplaceChar(Result, #0, #13);
      end
    end;
    RegCloseKey(phkResult);
  end;
end;

function _regQueryValue(var phkResult: HKEY; lpValueName: PChar; lpType: DWORD = REG_NONE): String;
var
  i: Integer;
  lpData: Pointer;
  lpcbData, dwResult: DWORD;
  sResult: String;
  lpResult: PByteArray;
begin
  Result := '';
  if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, nil, @lpcbData) = ERROR_SUCCESS then
  begin
    GetMem(lpData, lpcbData);
    if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, lpData, @lpcbData) = ERROR_SUCCESS then
    begin
      { strings }
      if (lpType = REG_SZ) or (lpType = REG_EXPAND_SZ) or (lpType = REG_MULTI_SZ) then
      begin
        Dec(lpcbData);
        SetLength(sResult, lpcbData);
        CopyMemory(@sResult[1], lpData, lpcbData);
        ReplaceChar(sResult, #0, ' '); { for MULTI SZ, Removes #0 }
        Result := sResult;
      end else
      { dword }
      if (lpType = REG_DWORD) then
      begin
        CopyMemory(@dwResult, lpData, lpcbData);
        Result := '0x' + IntToHex(dwResult, 8) + ' (' + IntToStr(dwResult) + ')';
      end else
      { binary }
      if (lpType = REG_BINARY) then
      begin
        if lpcbData <> 0 then
        begin
          GetMem(lpResult, lpcbData);
          CopyMemory(lpResult, lpData, lpcbData);
          for i := 0 to lpcbData do
            Result := Result + IntToHex(lpResult[i], 2) + ' ';
          // there are always some unused bytes at end, remove them ..
          Delete(Result, Length(Result) -3, 4);
          FreeMem(lpResult, lpcbData);
        end else
          Result := '(Zero Binary Value)';
      end else
      { none }
      if (lpType = REG_NONE) then
      begin
        Result := '(Value not set)';
      end;
    end;
    FreeMem(lpData, lpcbData);
  end;
end;

{ phkResult must be open with KEY_READ }
function _regQueryValueType(var phkResult: HKEY; lpValueName: PChar): String;
var
  lpType: DWORD;
begin
  if RegQueryValueEx(phkResult, lpValueName, nil, @lpType, nil, nil) <> ERROR_SUCCESS then
    lpType := REG_NONE;
  case lpType of
    REG_NONE: Result := 'REG_NONE';
    REG_SZ: Result := 'REG_SZ';
    REG_EXPAND_SZ: Result := 'REG_EXPAND_SZ';
    REG_BINARY: Result := 'REG_BINARY';
    REG_DWORD: Result := 'REG_DWORD';
    REG_DWORD_BIG_ENDIAN: Result := 'REG_DWORD_BIG_ENDIAN';
    REG_LINK: Result := 'REG_LINK';
    REG_MULTI_SZ: Result := 'REG_MULTI_SZ';
    REG_RESOURCE_LIST: Result := 'REG_RESOURCE_LIST';
    REG_FULL_RESOURCE_DESCRIPTOR: Result := 'REG_FULL_RESOURCE_DESCRIPTOR';
    REG_RESOURCE_REQUIREMENTS_LIST: Result := 'REG_RESOURCE_REQUIREMENTS_LIST';
  end;
end;

function _regEnumValues(hkKey: HKEY; lpSubKey: PChar): String;
var
  dwIndex, lpcbValueName: DWORD;
  phkResult: HKEY;
  lpValueName: Array[0..MAX_PATH] of Char;
  sResult, sType: String;
begin
  sResult := '';
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ, phkResult) = ERROR_SUCCESS then
  begin
    dwIndex := 0;
    lpcbValueName := sizeof(lpValueName);
    ZeroMemory(@lpValueName, sizeof(lpValueName));
    while RegEnumValue(phkResult, dwIndex, @lpValueName, lpcbValueName, nil, nil, nil, nil) <> ERROR_NO_MORE_ITEMS do
    begin
      sResult := sResult + lpValueName + '|' +  sType + #13#10;
      ZeroMemory(@lpValueName, sizeof(lpValueName));
      lpcbValueName := sizeof(lpValueName);
      inc(dwIndex);
    end;
    ReplaceChar(sResult, #0, ' ');
    RegCloseKey(phkResult);
    Result := sResult;
  end;
end;

function _regEnumKeys(hkKey: HKEY; lpSubKey: PChar): String;
var
  dwIndex, lpcbName: DWORD;
  phkResult: HKEY;
  lpName: Array[0..MAX_PATH] of Char;
  sResult: String;
begin
  sResult := '';
  if RegOpenKeyEx(hkKey, lpSubKey, 0, KEY_READ, phkResult) = ERROR_SUCCESS then
  begin
    dwIndex := 0;
    lpcbName := sizeof(lpName);
    ZeroMemory(@lpName, sizeof(lpName));
    while RegEnumKeyEx(phkResult, dwIndex, @lpName, lpcbName, nil, nil, nil, nil) <> ERROR_NO_MORE_ITEMS do
    begin
      sResult := sResult + lpName + #13#10;
      ZeroMemory(@lpName, sizeof(lpName));
      lpcbName := sizeof(lpName);
      inc(dwIndex);
    end;
    RegCloseKey(phkResult);
    Result := sResult;
  end;
end;



end.


Comments