kolregistry.pas

   1 unit kolregistry;
   2 // purpose: a KOL Registry object that mimics almost exactly VCL registry unit
   3 //          behaveour.
   4 //  author: KOL version © 2004, Thaddy de Koning
   5 //          Portions © 1995-1997 Borland Software Corporation
   6 //          Based on the Delphi3 professional sourcecode as distributed free with
   7 //          the Dutch magazine PC-Active in 2000.
   8
   9 {.$DEFINE USE_ERR} // If you want true exception handling
  10 interface
  11 uses
  12   windows, messages,kol{$IFDEF USE_ERR},err{$ENDIF};
  13
  14 type
  15
  16   TSysLocale = packed record
  17     DefaultLCID: Integer;
  18     PriLangID: Integer;
  19     SubLangID: Integer;
  20     FarEast: Boolean;
  21     MiddleEast: Boolean;
  22   end;
  23
  24   TRegKeyInfo = record
  25     NumSubKeys: Integer;
  26     MaxSubKeyLen: Integer;
  27     NumValues: Integer;
  28     MaxValueLen: Integer;
  29     MaxDataLen: Integer;
  30     FileTime: TFileTime;
  31   end;
  32
  33   TRegDataType = (rdUnknown, rdString, rdExpandString, rdInteger, rdBinary);
  34
  35   TRegDataInfo = record
  36     RegData: TRegDataType;
  37     DataSize: Integer;
  38   end;
  39
  40   PRegistry=^TRegistry;
  41   TRegistry = object(TObj)
  42   private
  43     FCurrentKey: HKEY;
  44     FRootKey: HKEY;
  45     FLazyWrite: Boolean;
  46     FCurrentPath: string;
  47     FCloseRootKey: Boolean;
  48     FAccess: LongWord;
  49     procedure SetRootKey(Value: HKEY);
  50   protected
  51     procedure ChangeKey(Value: HKey; const Path: string);
  52     function GetBaseKey(Relative: Boolean): HKey;
  53     function GetData(const Name: string; Buffer: Pointer;
  54       BufSize: Integer; var RegData: TRegDataType): Integer;
  55     function GetKey(const Key: string): HKEY;
  56     procedure PutData(const Name: string; Buffer: Pointer; BufSize: Integer; RegData: TRegDataType);
  57     procedure SetCurrentKey(Value: HKEY);
  58   public
  59     destructor Destroy; virtual;
  60     procedure CloseKey;
  61     function CreateKey(const Key: string): Boolean;
  62     function DeleteKey(const Key: string): Boolean;
  63     function DeleteValue(const Name: string): Boolean;
  64     function GetDataInfo(const ValueName: string; var Value: TRegDataInfo): Boolean;
  65     function GetDataSize(const ValueName: string): Integer;
  66     function GetDataType(const ValueName: string): TRegDataType;
  67     function GetKeyInfo(var Value: TRegKeyInfo): Boolean;
  68     procedure GetKeyNames(Strings: PStrList);
  69     procedure GetValueNames(Strings: PStrList);
  70     function HasSubKeys: Boolean;
  71     function KeyExists(const Key: string): Boolean;
  72     function LoadKey(const Key, FileName: string): Boolean;
  73     procedure MoveKey(const OldName, NewName: string; Delete: Boolean);
  74     function OpenKey(const Key: string; CanCreate: Boolean): Boolean;
  75     function OpenKeyReadOnly(const Key: String): Boolean;
  76     function ReadCurrency(const Name: string): Currency;
  77     function ReadBinaryData(const Name: string; var Buffer; BufSize: Integer): Integer;
  78     function ReadBool(const Name: string): Boolean;
  79     function ReadDate(const Name: string): TDateTime;
  80     function ReadDateTime(const Name: string): TDateTime;
  81     function ReadFloat(const Name: string): Double;
  82     function ReadInteger(const Name: string): Integer;
  83     function ReadString(const Name: string): string;
  84     function ReadTime(const Name: string): TDateTime;
  85     function RegistryConnect(const UNCName: string): Boolean;
  86     procedure RenameValue(const OldName, NewName: string);
  87     function ReplaceKey(const Key, FileName, BackUpFileName: string): Boolean;
  88     function RestoreKey(const Key, FileName: string): Boolean;
  89     function SaveKey(const Key, FileName: string): Boolean;
  90     function UnLoadKey(const Key: string): Boolean;
  91     function ValueExists(const Name: string): Boolean;
  92     procedure WriteCurrency(const Name: string; Value: Currency);
  93     procedure WriteBinaryData(const Name: string; var Buffer; BufSize: Integer);
  94     procedure WriteBool(const Name: string; Value: Boolean);
  95     procedure WriteDate(const Name: string; Value: TDateTime);
  96     procedure WriteDateTime(const Name: string; Value: TDateTime);
  97     procedure WriteFloat(const Name: string; Value: Double);
  98     procedure WriteInteger(const Name: string; Value: Integer);
  99     procedure WriteString(const Name, Value: string);
 100     procedure WriteExpandString(const Name, Value: string);
 101     procedure WriteTime(const Name: string; Value: TDateTime);
 102     property CurrentKey: HKEY read FCurrentKey;
 103     property CurrentPath: string read FCurrentPath;
 104     property LazyWrite: Boolean read FLazyWrite write FLazyWrite;
 105     property RootKey: HKEY read FRootKey write SetRootKey;
 106     property Access: LongWord read FAccess write FAccess;
 107   end;
 108
 109 function NewRegistry:PRegistry;overload;
 110 function NewRegistry(AAccess: LongWord):Pregistry;overload;
 111 function Str2IntDef(const S: string; Default: Integer): Integer;
 112
 113 var
 114   SysLocale:TSysLocale;
 115   LeadBytes: set of Char = [];
 116
 117 implementation
 118 const
 119   SInvalidRegType = 'Invalid data type for ''%s''';
 120   SRegCreateFailed = 'Failed to create key %s';
 121   SRegGetDataFailed = 'Failed to get data for ''%s''';
 122   SRegSetDataFailed = 'Failed to set data for ''%s''';
 123
 124 procedure ReadError(const Name: string);
 125 begin
 126 {$IFDEF USE_ERR}
 127   raise Exception.CreateFmt(e_Custom,SInvalidRegType, [Name]);
 128 {$ELSE}
 129   MsgOk(Format(SInvalidRegType, [Name]));
 130 {$ENDIF}
 131 end;
 132
 133 function IsRelative(const Value: string): Boolean;
 134 begin
 135   Result := not ((Value <> '') and (Value[1] = '\'));
 136 end;
 137
 138 function RegDataToDataType(Value: TRegDataType): Integer;
 139 begin
 140   case Value of
 141     rdString: Result := REG_SZ;
 142     rdExpandString: Result := REG_EXPAND_SZ;
 143     rdInteger: Result := REG_DWORD;
 144     rdBinary: Result := REG_BINARY;
 145   else
 146     Result := REG_NONE;
 147   end;
 148 end;
 149
 150 function DataTypeToRegData(Value: Integer): TRegDataType;
 151 begin
 152   if Value = REG_SZ then Result := rdString
 153   else if Value = REG_EXPAND_SZ then Result := rdExpandString
 154   else if Value = REG_DWORD then Result := rdInteger
 155   else if Value = REG_BINARY then Result := rdBinary
 156   else Result := rdUnknown;
 157 end;
 158
 159 function NewRegistry:PRegistry;overload;
 160 begin
 161   New(Result,Create);
 162   with Result^ do
 163   begin
 164     RootKey := HKEY_CURRENT_USER;
 165     FAccess := KEY_ALL_ACCESS;
 166     LazyWrite := True;
 167   end;
 168 end;
 169
 170 function NewRegistry(AAccess: LongWord):Pregistry;overload;
 171 begin
 172   Result:=NewRegistry;
 173   Result.FAccess := AAccess;
 174 end;
 175
 176 destructor TRegistry.Destroy;
 177 begin
 178   CloseKey;
 179   inherited;
 180 end;
 181
 182 procedure TRegistry.CloseKey;
 183 begin
 184   if CurrentKey <> 0 then
 185   begin
 186     if LazyWrite then
 187       RegCloseKey(CurrentKey) else
 188       RegFlushKey(CurrentKey);
 189     FCurrentKey := 0;
 190     FCurrentPath := '';
 191   end;
 192 end;
 193
 194 procedure TRegistry.SetRootKey(Value: HKEY);
 195 begin
 196   if RootKey <> Value then
 197   begin
 198     if FCloseRootKey then
 199     begin
 200       RegCloseKey(RootKey);
 201       FCloseRootKey := False;
 202     end;
 203     FRootKey := Value;
 204     CloseKey;
 205   end;
 206 end;
 207
 208 procedure TRegistry.ChangeKey(Value: HKey; const Path: string);
 209 begin
 210   CloseKey;
 211   FCurrentKey := Value;
 212   FCurrentPath := Path;
 213 end;
 214
 215 function TRegistry.GetBaseKey(Relative: Boolean): HKey;
 216 begin
 217   if (CurrentKey = 0) or not Relative then
 218     Result := RootKey else
 219     Result := CurrentKey;
 220 end;
 221
 222 procedure TRegistry.SetCurrentKey(Value: HKEY);
 223 begin
 224   FCurrentKey := Value;
 225 end;
 226
 227 function TRegistry.CreateKey(const Key: string): Boolean;
 228 var
 229   TempKey: HKey;
 230   S: string;
 231   Disposition: Integer;
 232   Relative: Boolean;
 233 begin
 234   TempKey := 0;
 235   S := Key;
 236   Relative := IsRelative(S);
 237   if not Relative then Delete(S, 1, 1);
 238   Result := RegCreateKeyEx(GetBaseKey(Relative), PChar(S), 0, nil,
 239     REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, TempKey, @Disposition) = ERROR_SUCCESS;
 240   if Result then RegCloseKey(TempKey)
 241   else
 242   {$IFDEF USE_ERR}
 243   raise Exception.CreateFmt(e_Custom,SRegCreateFailed, [Key]);
 244   {$ELSE}
 245   MsgOk(Format(SRegCreateFailed, [Key]));
 246   {$ENDIF}
 247 end;
 248
 249 function TRegistry.OpenKey(const Key: String; Cancreate: boolean): Boolean;
 250 var
 251   TempKey: HKey;
 252   S: string;
 253   Disposition: Integer;
 254   Relative: Boolean;
 255 begin
 256   S := Key;
 257   Relative := IsRelative(S);
 258
 259   if not Relative then Delete(S, 1, 1);
 260   TempKey := 0;
 261   if not CanCreate or (S = '') then
 262   begin
 263     Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
 264       FAccess, TempKey) = ERROR_SUCCESS;
 265   end else
 266     Result := RegCreateKeyEx(GetBaseKey(Relative), PChar(S), 0, nil,
 267       REG_OPTION_NON_VOLATILE, FAccess, nil, TempKey, @Disposition) = ERROR_SUCCESS;
 268   if Result then
 269   begin
 270     if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
 271     ChangeKey(TempKey, S);
 272   end;
 273 end;
 274
 275 function TRegistry.OpenKeyReadOnly(const Key: String): Boolean;
 276 var
 277   TempKey: HKey;
 278   S: string;
 279   Relative: Boolean;
 280 begin
 281   S := Key;
 282   Relative := IsRelative(S);
 283
 284   if not Relative then Delete(S, 1, 1);
 285   TempKey := 0;
 286   Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
 287       KEY_READ, TempKey) = ERROR_SUCCESS;
 288   if Result then
 289   begin
 290     FAccess := KEY_READ;
 291     if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
 292     ChangeKey(TempKey, S);
 293   end
 294   else
 295   begin
 296     Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
 297         STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS,
 298         TempKey) = ERROR_SUCCESS;
 299     if Result then
 300     begin
 301       FAccess := STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS;
 302       if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
 303       ChangeKey(TempKey, S);
 304     end
 305     else
 306     begin
 307       Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
 308           KEY_QUERY_VALUE, TempKey) = ERROR_SUCCESS;
 309       if Result then
 310       begin
 311         FAccess := KEY_QUERY_VALUE;
 312         if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
 313         ChangeKey(TempKey, S);
 314       end
 315     end;
 316   end;
 317 end;
 318
 319 function TRegistry.DeleteKey(const Key: string): Boolean;
 320 var
 321   Len: DWORD;
 322   I: Integer;
 323   Relative: Boolean;
 324   S, KeyName: string;
 325   OldKey, aDeleteKey: HKEY;
 326   Info: TRegKeyInfo;
 327 begin
 328   S := Key;
 329   Relative := IsRelative(S);
 330   if not Relative then Delete(S, 1, 1);
 331   OldKey := CurrentKey;
 332   aDeleteKey := GetKey(Key);
 333   if aDeleteKey <> 0 then
 334   try
 335     SetCurrentKey(aDeleteKey);
 336     if GetKeyInfo(Info) then
 337     begin
 338       SetString(KeyName, nil, Info.MaxSubKeyLen + 1);
 339       for I := Info.NumSubKeys - 1 downto 0 do
 340       begin
 341         Len := Info.MaxSubKeyLen + 1;
 342         if RegEnumKeyEx(aDeleteKey, DWORD(I), PChar(KeyName), Len, nil, nil, nil,
 343           nil) = ERROR_SUCCESS then
 344           Self.DeleteKey(PChar(KeyName));
 345       end;
 346     end;
 347   finally
 348     SetCurrentKey(OldKey);
 349     RegCloseKey(aDeleteKey);
 350   end;
 351   Result := RegDeleteKey(GetBaseKey(Relative), PChar(S)) = ERROR_SUCCESS;
 352 end;
 353
 354 function TRegistry.DeleteValue(const Name: string): Boolean;
 355 begin
 356   Result := RegDeleteValue(CurrentKey, PChar(Name)) = ERROR_SUCCESS;
 357 end;
 358
 359 function TRegistry.GetKeyInfo(var Value: TRegKeyInfo): Boolean;
 360 begin
 361   FillChar(Value, SizeOf(TRegKeyInfo), 0);
 362   Result := RegQueryInfoKey(CurrentKey, nil, nil, nil, @Value.NumSubKeys,
 363     @Value.MaxSubKeyLen, nil, @Value.NumValues, @Value.MaxValueLen,
 364     @Value.MaxDataLen, nil, @Value.FileTime) = ERROR_SUCCESS;
 365   if SysLocale.FarEast and (WinVer >= WvNT) then
 366     with Value do
 367     begin
 368       Inc(MaxSubKeyLen, MaxSubKeyLen);
 369       Inc(MaxValueLen, MaxValueLen);
 370     end;
 371 end;
 372
 373 procedure TRegistry.GetKeyNames(Strings: PStrList);
 374 var
 375   Len: DWORD;
 376   I: Integer;
 377   Info: TRegKeyInfo;
 378   S: string;
 379 begin
 380   Strings.Clear;
 381   if GetKeyInfo(Info) then
 382   begin
 383     SetString(S, nil, Info.MaxSubKeyLen + 1);
 384     for I := 0 to Info.NumSubKeys - 1 do
 385     begin
 386       Len := Info.MaxSubKeyLen + 1;
 387       RegEnumKeyEx(CurrentKey, I, PChar(S), Len, nil, nil, nil, nil);
 388       Strings.Add(PChar(S));
 389     end;
 390   end;
 391 end;
 392
 393 procedure TRegistry.GetValueNames(Strings: PStrList);
 394 var
 395   Len: DWORD;
 396   I: Integer;
 397   Info: TRegKeyInfo;
 398   S: string;
 399 begin
 400   Strings.Clear;
 401   if GetKeyInfo(Info) then
 402   begin
 403     SetString(S, nil, Info.MaxValueLen + 1);
 404     for I := 0 to Info.NumValues - 1 do
 405     begin
 406       Len := Info.MaxValueLen + 1;
 407       RegEnumValue(CurrentKey, I, PChar(S), Len, nil, nil, nil, nil);
 408       Strings.Add(PChar(S));
 409     end;
 410   end;
 411 end;
 412
 413 function TRegistry.GetDataInfo(const ValueName: string; var Value: TRegDataInfo): Boolean;
 414 var
 415   DataType: Integer;
 416 begin
 417   FillChar(Value, SizeOf(TRegDataInfo), 0);
 418   Result := RegQueryValueEx(CurrentKey, PChar(ValueName), nil, @DataType, nil,
 419     @Value.DataSize) = ERROR_SUCCESS;
 420   Value.RegData := DataTypeToRegData(DataType);
 421 end;
 422
 423 function TRegistry.GetDataSize(const ValueName: string): Integer;
 424 var
 425   Info: TRegDataInfo;
 426 begin
 427   if GetDataInfo(ValueName, Info) then
 428     Result := Info.DataSize else
 429     Result := -1;
 430 end;
 431
 432 function TRegistry.GetDataType(const ValueName: string): TRegDataType;
 433 var
 434   Info: TRegDataInfo;
 435 begin
 436   if GetDataInfo(ValueName, Info) then
 437     Result := Info.RegData else
 438     Result := rdUnknown;
 439 end;
 440
 441 procedure TRegistry.WriteString(const Name, Value: string);
 442 begin
 443   PutData(Name, PChar(Value), Length(Value)+1, rdString);
 444 end;
 445
 446 procedure TRegistry.WriteExpandString(const Name, Value: string);
 447 begin
 448   PutData(Name, PChar(Value), Length(Value)+1, rdExpandString);
 449 end;
 450
 451 function TRegistry.ReadString(const Name: string): string;
 452 var
 453   Len: Integer;
 454   RegData: TRegDataType;
 455 begin
 456   Len := GetDataSize(Name);
 457   if Len > 0 then
 458   begin
 459     SetString(Result, nil, Len);
 460     GetData(Name, PChar(Result), Len, RegData);
 461     if (RegData = rdString) or (RegData = rdExpandString) then
 462       SetLength(Result, StrLen(PChar(Result)))
 463     else ReadError(Name);
 464   end
 465   else Result := '';
 466 end;
 467
 468 procedure TRegistry.WriteInteger(const Name: string; Value: Integer);
 469 begin
 470   PutData(Name, @Value, SizeOf(Integer), rdInteger);
 471 end;
 472
 473 function TRegistry.ReadInteger(const Name: string): Integer;
 474 var
 475   RegData: TRegDataType;
 476 begin
 477   GetData(Name, @Result, SizeOf(Integer), RegData);
 478   if RegData <> rdInteger then ReadError(Name);
 479 end;
 480
 481 procedure TRegistry.WriteBool(const Name: string; Value: Boolean);
 482 begin
 483   WriteInteger(Name, Ord(Value));
 484 end;
 485
 486 function TRegistry.ReadBool(const Name: string): Boolean;
 487 begin
 488   Result := ReadInteger(Name) <> 0;
 489 end;
 490
 491 procedure TRegistry.WriteFloat(const Name: string; Value: Double);
 492 begin
 493   PutData(Name, @Value, SizeOf(Double), rdBinary);
 494 end;
 495
 496 function TRegistry.ReadFloat(const Name: string): Double;
 497 var
 498   Len: Integer;
 499   RegData: TRegDataType;
 500 begin
 501   Len := GetData(Name, @Result, SizeOf(Double), RegData);
 502   if (RegData <> rdBinary) or (Len <> SizeOf(Double)) then
 503     ReadError(Name);
 504 end;
 505
 506 procedure TRegistry.WriteCurrency(const Name: string; Value: Currency);
 507 begin
 508   PutData(Name, @Value, SizeOf(Currency), rdBinary);
 509 end;
 510
 511 function TRegistry.ReadCurrency(const Name: string): Currency;
 512 var
 513   Len: Integer;
 514   RegData: TRegDataType;
 515 begin
 516   Len := GetData(Name, @Result, SizeOf(Currency), RegData);
 517   if (RegData <> rdBinary) or (Len <> SizeOf(Currency)) then
 518     ReadError(Name);
 519 end;
 520
 521 procedure TRegistry.WriteDateTime(const Name: string; Value: TDateTime);
 522 begin
 523   PutData(Name, @Value, SizeOf(TDateTime), rdBinary);
 524 end;
 525
 526 function TRegistry.ReadDateTime(const Name: string): TDateTime;
 527 var
 528   Len: Integer;
 529   RegData: TRegDataType;
 530 begin
 531   Len := GetData(Name, @Result, SizeOf(TDateTime), RegData);
 532   if (RegData <> rdBinary) or (Len <> SizeOf(TDateTime)) then
 533     ReadError(Name);
 534 end;
 535
 536 procedure TRegistry.WriteDate(const Name: string; Value: TDateTime);
 537 begin
 538   WriteDateTime(Name, Value);
 539 end;
 540
 541 function TRegistry.ReadDate(const Name: string): TDateTime;
 542 begin
 543   Result := ReadDateTime(Name);
 544 end;
 545
 546 procedure TRegistry.WriteTime(const Name: string; Value: TDateTime);
 547 begin
 548   WriteDateTime(Name, Value);
 549 end;
 550
 551 function TRegistry.ReadTime(const Name: string): TDateTime;
 552 begin
 553   Result := ReadDateTime(Name);
 554 end;
 555
 556 procedure TRegistry.WriteBinaryData(const Name: string; var Buffer; BufSize: Integer);
 557 begin
 558   PutData(Name, @Buffer, BufSize, rdBinary);
 559 end;
 560
 561 function TRegistry.ReadBinaryData(const Name: string; var Buffer; BufSize: Integer): Integer;
 562 var
 563   RegData: TRegDataType;
 564   Info: TRegDataInfo;
 565 begin
 566   if GetDataInfo(Name, Info) then
 567   begin
 568     Result := Info.DataSize;
 569     RegData := Info.RegData;
 570     if ((RegData = rdBinary) or (RegData = rdUnknown)) and (Result <= BufSize) then
 571       GetData(Name, @Buffer, Result, RegData)
 572     else ReadError(Name);
 573   end else
 574     Result := 0;
 575 end;
 576
 577 procedure TRegistry.PutData(const Name: string; Buffer: Pointer;
 578   BufSize: Integer; RegData: TRegDataType);
 579 var
 580   DataType: Integer;
 581 begin
 582   DataType := RegDataToDataType(RegData);
 583   if RegSetValueEx(CurrentKey, PChar(Name), 0, DataType, Buffer,
 584     BufSize) <> ERROR_SUCCESS then
 585     {$IFDEF USE_ERR}
 586     raise Exception.CreateFmt(e_Custom,SRegSetDataFailed, [Name]);
 587     {$ELSE}
 588     MsgOk(Format(SRegSetDataFailed, [Name]));
 589     {$ENDIF}
 590 end;
 591
 592 function TRegistry.GetData(const Name: string; Buffer: Pointer;
 593   BufSize: Integer; var RegData: TRegDataType): Integer;
 594 var
 595   DataType: Integer;
 596 begin
 597   DataType := REG_NONE;
 598   if RegQueryValueEx(CurrentKey, PChar(Name), nil, @DataType, PByte(Buffer),
 599     @BufSize) <> ERROR_SUCCESS then
 600     {$IFDEF USE_ERR}
 601     raise Exception.CreateFmt(e_Custom,SRegGetDataFailed, [Name]);
 602     {$ELSE}
 603     begin
 604       Result:=0;
 605       MsgOk(Format(SRegGetDataFailed, [Name]));
 606     end else
 607     {$ENDIF}
 608   Result := BufSize;
 609   RegData := DataTypeToRegData(DataType);
 610 end;
 611
 612 function TRegistry.HasSubKeys: Boolean;
 613 var
 614   Info: TRegKeyInfo;
 615 begin
 616   Result := GetKeyInfo(Info) and (Info.NumSubKeys > 0);
 617 end;
 618
 619 function TRegistry.ValueExists(const Name: string): Boolean;
 620 var
 621   Info: TRegDataInfo;
 622 begin
 623   Result := GetDataInfo(Name, Info);
 624 end;
 625
 626 function TRegistry.GetKey(const Key: string): HKEY;
 627 var
 628   S: string;
 629   Relative: Boolean;
 630 begin
 631   S := Key;
 632   Relative := IsRelative(S);
 633   if not Relative then Delete(S, 1, 1);
 634   Result := 0;
 635   RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0, FAccess, Result);
 636 end;
 637
 638 function TRegistry.RegistryConnect(const UNCName: string): Boolean;
 639 var
 640   TempKey: HKEY;
 641 begin
 642   Result := RegConnectRegistry(PChar(UNCname), RootKey, TempKey) = ERROR_SUCCESS;
 643   if Result then
 644   begin
 645     RootKey := TempKey;
 646     FCloseRootKey := True;
 647   end;
 648 end;
 649
 650 function TRegistry.LoadKey(const Key, FileName: string): Boolean;
 651 var
 652   S: string;
 653 begin
 654   S := Key;
 655   if not IsRelative(S) then Delete(S, 1, 1);
 656   Result := RegLoadKey(RootKey, PChar(S), PChar(FileName)) = ERROR_SUCCESS;
 657 end;
 658
 659 function TRegistry.UnLoadKey(const Key: string): Boolean;
 660 var
 661   S: string;
 662 begin
 663   S := Key;
 664   if not IsRelative(S) then Delete(S, 1, 1);
 665   Result := RegUnLoadKey(RootKey, PChar(S)) = ERROR_SUCCESS;
 666 end;
 667
 668 function TRegistry.RestoreKey(const Key, FileName: string): Boolean;
 669 var
 670   aRestoreKey: HKEY;
 671 begin
 672   Result := False;
 673   aRestoreKey := GetKey(Key);
 674   if aRestoreKey <> 0 then
 675   try
 676     Result := RegRestoreKey(aRestoreKey, PChar(FileName), 0) = ERROR_SUCCESS;
 677   finally
 678     RegCloseKey(aRestoreKey);
 679   end;
 680 end;
 681
 682 function TRegistry.ReplaceKey(const Key, FileName, BackUpFileName: string): Boolean;
 683 var
 684   S: string;
 685   Relative: Boolean;
 686 begin
 687   S := Key;
 688   Relative := IsRelative(S);
 689   if not Relative then Delete(S, 1, 1);
 690   Result := RegReplaceKey(GetBaseKey(Relative), PChar(S),
 691     PChar(FileName), PChar(BackUpFileName)) = ERROR_SUCCESS;
 692 end;
 693
 694 function TRegistry.SaveKey(const Key, FileName: string): Boolean;
 695 var
 696   aSaveKey: HKEY;
 697 begin
 698   Result := False;
 699   aSaveKey := GetKey(Key);
 700   if aSaveKey <> 0 then
 701   try
 702     Result := RegSaveKey(aSaveKey, PChar(FileName), nil) = ERROR_SUCCESS;
 703   finally
 704     RegCloseKey(aSaveKey);
 705   end;
 706 end;
 707
 708 function TRegistry.KeyExists(const Key: string): Boolean;
 709 var
 710   TempKey: HKEY;
 711   OldAccess: Longword;
 712 begin
 713   OldAccess := FAccess;
 714   try
 715     FAccess := STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS;
 716     TempKey := GetKey(Key);
 717     if TempKey <> 0 then RegCloseKey(TempKey);
 718     Result := TempKey <> 0;
 719   finally
 720     FAccess := OldAccess;
 721   end;
 722 end;
 723
 724 procedure TRegistry.RenameValue(const OldName, NewName: string);
 725 var
 726   Len: Integer;
 727   RegData: TRegDataType;
 728   Buffer: PChar;
 729 begin
 730   if ValueExists(OldName) and not ValueExists(NewName) then
 731   begin
 732     Len := GetDataSize(OldName);
 733     if Len > 0 then
 734     begin
 735       Buffer := AllocMem(Len);
 736       try
 737         Len := GetData(OldName, Buffer, Len, RegData);
 738         DeleteValue(OldName);
 739         PutData(NewName, Buffer, Len, RegData);
 740       finally
 741         FreeMem(Buffer);
 742       end;
 743     end;
 744   end;
 745 end;
 746
 747 procedure TRegistry.MoveKey(const OldName, NewName: string; Delete: Boolean);
 748 var
 749   SrcKey, DestKey: HKEY;
 750
 751   procedure MoveValue(SrcKey, DestKey: HKEY; const Name: string);
 752   var
 753     Len: Integer;
 754     OldKey, PrevKey: HKEY;
 755     Buffer: PChar;
 756     RegData: TRegDataType;
 757   begin
 758     OldKey := CurrentKey;
 759     SetCurrentKey(SrcKey);
 760     try
 761       Len := GetDataSize(Name);
 762       if Len > 0 then
 763       begin
 764         Buffer := AllocMem(Len);
 765         try
 766           Len := GetData(Name, Buffer, Len, RegData);
 767           PrevKey := CurrentKey;
 768           SetCurrentKey(DestKey);
 769           try
 770             PutData(Name, Buffer, Len, RegData);
 771           finally
 772             SetCurrentKey(PrevKey);
 773           end;
 774         finally
 775           FreeMem(Buffer);
 776         end;
 777       end;
 778     finally
 779       SetCurrentKey(OldKey);
 780     end;
 781   end;
 782
 783   procedure CopyValues(SrcKey, DestKey: HKEY);
 784   var
 785     Len: DWORD;
 786     I: Integer;
 787     KeyInfo: TRegKeyInfo;
 788     S: string;
 789     OldKey: HKEY;
 790   begin
 791     OldKey := CurrentKey;
 792     SetCurrentKey(SrcKey);
 793     try
 794       if GetKeyInfo(KeyInfo) then
 795       begin
 796         MoveValue(SrcKey, DestKey, '');
 797         SetString(S, nil, KeyInfo.MaxValueLen + 1);
 798         for I := 0 to KeyInfo.NumValues - 1 do
 799         begin
 800           Len := KeyInfo.MaxValueLen + 1;
 801           if RegEnumValue(SrcKey, I, PChar(S), Len, nil, nil, nil, nil) = ERROR_SUCCESS then
 802             MoveValue(SrcKey, DestKey, PChar(S));
 803         end;
 804       end;
 805     finally
 806       SetCurrentKey(OldKey);
 807     end;
 808   end;
 809
 810   procedure CopyKeys(SrcKey, DestKey: HKEY);
 811   var
 812     Len: DWORD;
 813     I: Integer;
 814     Info: TRegKeyInfo;
 815     S: string;
 816     OldKey, PrevKey, NewSrc, NewDest: HKEY;
 817   begin
 818     OldKey := CurrentKey;
 819     SetCurrentKey(SrcKey);
 820     try
 821       if GetKeyInfo(Info) then
 822       begin
 823         SetString(S, nil, Info.MaxSubKeyLen + 1);
 824         for I := 0 to Info.NumSubKeys - 1 do
 825         begin
 826           Len := Info.MaxSubKeyLen + 1;
 827           if RegEnumKeyEx(SrcKey, I, PChar(S), Len, nil, nil, nil, nil) = ERROR_SUCCESS then
 828           begin
 829             NewSrc := GetKey(PChar(S));
 830             if NewSrc <> 0 then
 831             try
 832               PrevKey := CurrentKey;
 833               SetCurrentKey(DestKey);
 834               try
 835                 CreateKey(PChar(S));
 836                 NewDest := GetKey(PChar(S));
 837                 try
 838                   CopyValues(NewSrc, NewDest);
 839                   CopyKeys(NewSrc, NewDest);
 840                 finally
 841                   RegCloseKey(NewDest);
 842                 end;
 843               finally
 844                 SetCurrentKey(PrevKey);
 845               end;
 846             finally
 847               RegCloseKey(NewSrc);
 848             end;
 849           end;
 850         end;
 851       end;
 852     finally
 853       SetCurrentKey(OldKey);
 854     end;
 855   end;
 856
 857 begin
 858   if KeyExists(OldName) and not KeyExists(NewName) then
 859   begin
 860     SrcKey := GetKey(OldName);
 861     if SrcKey <> 0 then
 862     try
 863       CreateKey(NewName);
 864       DestKey := GetKey(NewName);
 865       if DestKey <> 0 then
 866       try
 867         CopyValues(SrcKey, DestKey);
 868         CopyKeys(SrcKey, DestKey);
 869         if Delete then DeleteKey(OldName);
 870       finally
 871         RegCloseKey(DestKey);
 872       end;
 873     finally
 874       RegCloseKey(SrcKey);
 875     end;
 876   end;
 877 end;
 878
 879 function Str2IntDef(const S: string; Default: Integer): Integer;
 880 var
 881   E: Integer;
 882 begin
 883   Val(S, Result, E);
 884   if E <> 0 then Result := Default;
 885 end;
 886
 887 function LCID2CodePage(ALcid: LCID): Integer;
 888 var
 889   Buffer: array [0..6] of Char;
 890 begin
 891   GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer));
 892   Result:= Str2IntDef(Buffer, GetACP);
 893 end;
 894
 895 procedure InitSysLocale;
 896 var
 897   DefaultLCID: LCID;
 898   DefaultLangID: LANGID;
 899   AnsiCPInfo: TCPInfo;
 900   I: Integer;
 901   BufferA: array [128..255] of Char;
 902   BufferW: array [128..256] of Word;
 903   PCharA: PChar;
 904
 905   procedure InitLeadBytes;
 906   var
 907     I: Integer;
 908     J: Byte;
 909   begin
 910     GetCPInfo(LCID2CodePage(SysLocale.DefaultLCID), AnsiCPInfo);
 911     with AnsiCPInfo do
 912     begin
 913       I := 0;
 914       while (I < MAX_LEADBYTES) and ((LeadByte[I] or LeadByte[I + 1]) <> 0) do
 915       begin
 916         for J := LeadByte[I] to LeadByte[I + 1] do
 917           Include(LeadBytes, Char(J));
 918         Inc(I, 2);
 919       end;
 920     end;
 921   end;
 922
 923   function IsWesternGroup: Boolean;
 924   type
 925     TLangGroup = $00..$1D;
 926     TLangGroups = set of TLangGroup;
 927   const
 928     lgNeutral = TLangGroup($00);
 929     lgDanish = TLangGroup($06);
 930     lgDutch = TLangGroup($13);
 931     lgEnglish  = TLangGroup($09);
 932     lgFinnish = TLangGroup($0B);
 933     lgFrench = TLangGroup($0C);
 934     lgGerman = TLangGroup($07);
 935     lgItalian  = TLangGroup($10);
 936     lgNorwegian = TLangGroup($14);
 937     lgPortuguese = TLangGroup($16);
 938     lgSpanish  = TLangGroup($0A);
 939     lgSwedish  = TLangGroup($1D);
 940
 941     WesternGroups: TLangGroups = [
 942       lgNeutral,
 943       lgDanish,
 944       lgDutch,
 945       lgEnglish,
 946       lgFinnish,
 947       lgFrench,
 948       lgGerman,
 949       lgItalian,
 950       lgNorwegian,
 951       lgPortuguese,
 952       lgSpanish,
 953       lgSwedish
 954     ];
 955   begin
 956     Result := SysLocale.PriLangID in WesternGroups;
 957   end;
 958
 959 begin
 960   { Set default to English (US). }
 961   SysLocale.DefaultLCID := $0409;
 962   SysLocale.PriLangID := LANG_ENGLISH;
 963   SysLocale.SubLangID := SUBLANG_ENGLISH_US;
 964
 965   DefaultLCID := GetThreadLocale;
 966   if DefaultLCID <> 0 then SysLocale.DefaultLCID := DefaultLCID;
 967
 968   DefaultLangID := Word(DefaultLCID);
 969   if DefaultLangID <> 0 then
 970   begin
 971     SysLocale.PriLangID := DefaultLangID and $3ff;
 972     SysLocale.SubLangID := DefaultLangID shr 10;
 973   end;
 974
 975   LeadBytes := [];
 976   if WinVer  >= wvNT then
 977   begin
 978     if IsWesternGroup then
 979     begin
 980       SysLocale.MiddleEast := False;
 981       SysLocale.FarEast    := False;
 982     end
 983     else
 984     begin
 985       { Far East (aka MBCS)? - }
 986       InitLeadBytes;
 987       SysLocale.FarEast := LeadBytes <> [];
 988       if SysLocale.FarEast then
 989       begin
 990         SysLocale.MiddleEast := False;
 991         Exit;
 992       end;
 993
 994       { Middle East? }
 995       for I := Low(BufferA) to High(BufferA) do
 996         BufferA[I] := Char(I);
 997       PCharA := @BufferA; { not null terminated: include length in GetStringTypeExA call }
 998       GetStringTypeEx(SysLocale.DefaultLCID, CT_CTYPE2, PCharA, High(BufferA) - Low(BufferA) + 1, BufferW);
 999       for I := Low(BufferA) to High(BufferA) do
1000       begin
1001         SysLocale.MiddleEast := BufferW[I] = C2_RIGHTTOLEFT;
1002         if SysLocale.MiddleEast then
1003           Exit;
1004       end;
1005     end;
1006   end
1007   else
1008   begin
1009     SysLocale.MiddleEast := GetSystemMetrics(SM_MIDEASTENABLED) <> 0;
1010     SysLocale.FarEast    := GetSystemMetrics(SM_DBCSENABLED) <> 0;
1011     if SysLocale.FarEast then
1012       InitLeadBytes;
1013   end;
1014 end;
1015 initialization
1016  initsyslocale;
1017 end.