Export Complete Registry

Der folgende Code ist in der Lage, den gesamten Inhalt der Registrierung als Verzeichnisbaum in einer Datei zu speichern. Da die Registrierung von Windows sehr groß ist, kann der Prozess einige Minuten dauern und dem entsprechen ist auch die Größe der Datei recht groß.

unit RegTreeList.pas

unit RegTreeList;

interface

{$WARNINGS OFF}

uses Windows, Classes, SysUtils, Registry, Dialogs;

type TRGProgression = procedure(Event:word) of object;

const RG_Base     = 0 ;
      RG_Start    = RG_Base+1;
      RG_Progress = RG_Base+2;
      RG_End      = RG_Base+3;
      RG_Refresh  = RG_Base+4;

var RG_MaxDepthFound : word;

  procedure EnumRegistryFolders(FileName:string);
  procedure RG_SetProgressor(P:TRGProgression);
  function RG_IsCompleted:boolean;
  function RG_LongestKey:string;

implementation

const PasTouche   = FALSE;
      MAX_LEVEL   = 16;

      CH_TabStyle = '   ';
      RootName    : array[0..6] of string[21] = ('HKEY_CLASSES_ROOT', 'HKEY_CURRENT_USER',
                                                 'HKEY_LOCAL_MACHINE', 'HKEY_USERS',
                                                 'HKEY_PERFORMANCE_DATA', 'HKEY_CURRENT_CONFIG',
                                                 'HKEY_DYN_DATA');

      ShortRootName : array[0..6] of string[4] = ('HKCR', 'HKCU', 'HKLM', 'HKU', 'HKPD', 'HKCC', 'HKDD');


var STL         : TStringList;
    Tbls        : array[0..MAX_LEVEL] of TStringList;
    RegPath     : array[0..MAX_LEVEL] of string;
    Fic         : textfile;
    Reg         : TRegistry;
    n           : byte;
    Completed   : boolean;
    KeyMaxDepth : string;
    RG          : TRGProgression;

  function GetRefPath(Lvl:cardinal):string;
  var r : string;
      x : cardinal;
  begin
    r:='';
    if Lvl>0 then
      for x:=0 to Lvl-1 do
        r:=r+RegPath[x]+'\';
    GetRefPath:=r;
  end;

  function LevelToTabs(N:cardinal):string;
  var x : cardinal;
      r : string;
  begin
    r:='';
    for x:=0 to N do
      r:=r+CH_TabStyle;
    LevelToTabs:=r;
  end;

  procedure RecurseSubKeys(KeyName: string; var F:textfile; Level, Root:integer);
  var x : integer;
  begin
    if Level>RG_MaxDepthFound then
      begin
        RG_MaxDepthFound:=Level;
        KeyMaxDepth:=ShortRootName[Root]+'\'+GetRefPath(Level);
      end;
    if Level>MAX_LEVEL-1 then
      begin
        Completed:=false;
        Exit;
      end;
    RegPath[Level]:=KeyName;
    Tbls[Level].Clear;
    Reg.OpenKey(GetRefPath(Level)+KeyName, PasTouche);
      Reg.GetKeyNames(Tbls[Level]);
    Reg.CloseKey;
    Tbls[Level].Sort;
    for x:=0 to Tbls[Level].Count-1 do
      begin
        WriteLn(F, LevelToTabs(Level)+Tbls[Level][x]+'\');
        RecurseSubKeys(Tbls[Level][x], F, Level+1, Root);
      end;
    Tbls[Level].Clear;
  end;

  procedure ProcessMainBranch(Root:integer; var F:textfile);
  var x : integer;
  begin
    STL.Clear;
    Reg.RootKey:=HKEY_CLASSES_ROOT+Root;
    WriteLn(F, '#== PRINCIPAL ==#   ::   '+RootName[Root]);
    Reg.OpenKey('',PasTouche);
      Reg.GetKeyNames(STL);
    Reg.CloseKey;
    STL.Sort;
    for x:=0 to STL.Count-1 do
      begin
        WriteLn(F, STL[x]+'\');
        RecurseSubKeys(STL[x], F, 0, Root);
      end;
    STL.Clear;
    WriteLn(F);
    WriteLn(F);
  end;

procedure GoRegTree(var F:textfile);
var x : byte;
begin
  Completed:=true;
  RG_MaxDepthFound:=0;
  KeyMaxDepth:='';
  for x:=0 to 6 do
    begin
      ProcessMainBranch(x,F);
      if Assigned(RG) then RG(RG_Progress);
    end;
  KeyMaxDepth:=KeyMaxDepth+'...';
  RG_MaxDepthFound:=RG_MaxDepthFound+1;
end;

procedure EnumRegistryFolders(FileName:string);
var x : byte;
begin
  if FileExists(FileName) then
    if MessageDlg('Voulez-vous remplacer le fichier ?',mtConfirmation,[mbYes,mbNo],0)=idNo then
      EXIT;
  if Assigned(RG) then RG(RG_Refresh);
  AssignFile(Fic,FileName);
  try
    Rewrite(Fic);
    Reg:=TRegistry.Create;
    try
      if Assigned(RG) then RG(RG_Start);
      GoRegTree(Fic);
      for x:=0 to MAX_LEVEL do
        begin
          Tbls[x].Clear;
          RegPath[x]:='';
        end;
    finally
      Reg.Free;
    end;
  finally
    CloseFile(Fic);
  end;
  if Assigned(RG) then RG(RG_End);
end;

function RG_IsCompleted:boolean;
begin
  RG_IsCompleted:=Completed
end;

function RG_LongestKey:string;
begin
  RG_LongestKey:=KeyMaxDepth;
end;

procedure RG_SetProgressor(P:TRGProgression);
begin
  if Assigned(P) then RG:=P;
end;

initialization
  RG:=nil;
  STL:=TStringList.Create;
  for n:=0 to MAX_LEVEL do
    begin
      Tbls[n]:=TStringList.Create;
      RegPath[n]:='';
    end;

finalization
  STL.Free;
  for n:=0 to MAX_LEVEL do
    begin
      Tbls[n].Free;
      RegPath[n]:='';
    end;

end.

Unit1 :

uses RegTreeList

private
    procedure Progress(Event:word);
    
//

procedure TForm1.Progress(Event:word);
var r : string;
begin
  case Event of
    RG_Base:;
    RG_Start: begin
                Form1.Gauge.Position:=0;
                Form1.Gauge.Max:=7;
              end;
    RG_Progress: begin
                   Form1.Gauge.Position:= Form1.Gauge.Position+1;
                   Form1.Refresh;
                   Sleep(1500);
                 end;
    RG_End: begin
              Form1.Gauge.Position:=0;
              r:='Process completed.'+#13#10;
              r:=r+#13#10+'The maximum depth found is '+IntToStr(RG_MaxDepthFound)+'.';
              r:=r+#13#10+'for the key "'+RG_LongestKey+'".';
              if not RG_IsCompleted then
                r:=r+#13#10#13#10+'However, some keys have not been written.';
              MessageDlg(r,mtConfirmation,[mbOk],0);
            end;
    RG_Refresh: Form1.Refresh;
    else ;
  end;
end;

Beispiel :

procedure TForm1.butGenClick(Sender: TObject);
begin
  RG_SetProgressor(Progress);
  EnumRegistryFolders(Edit1.Text);
end;