Ver Mensaje Individual
  #4  
Antiguo 08-05-2003
Periyo Periyo is offline
Miembro
 
Registrado: may 2003
Posts: 17
Reputación: 0
Periyo Va por buen camino
Thumbs up Asi lo hace Windows

Ya encontre la solución al problema. Encontre una funcioncilla muy interesante, mas que una funcion es toda una unidad.

Aqui os la dejo.

Solo teneis que crear una unidad y meter todo este código. Despues es cuestión de llamar al procedimiento "procedure ExportKey ( RootKey : HKEY; Key : String;
FileName : String; Overwrite : Boolean );"

Mandando como paramatros: Root,Direcion de la clave,Direccion y nombre del archivo donde se hara la copia, true para que sobrescriba si ya existiera el archivo o falso para que no lo sobrescriba.


unit ExportarRegistro;


interface

uses Windows,Classes,Registry,SysUtils;

const
ExportHeader = 'REGEDIT4';

procedure ExportKey ( RootKey : HKEY; Key : String;
FileName : String; Overwrite : Boolean );

implementation

type
TSubstitution = record
Character : char;
Substitution : String;
end;

const
SubstitutionsConst : array [1..4] of TSubstitution =
( (Character : #10; Substitution : '\n'),
(Character : #13; Substitution : '\r'),
(Character : '"'; Substitution : '\"'),
(Character : '\'; Substitution : '\\')
);

var
Substitutions : array [1..255] of String;

procedure Initialize;
var
i : Integer;
begin
for i:=low(Substitutions) to high(Substitutions) do
Substitutions[i]:='';

for i:=low(SubstitutionsConst) to high(SubstitutionsConst) do
Substitutions[ord(SubstitutionsConst[i].Character)]:=
SubstitutionsConst[i].Substitution;
end;

function RegistryRootKeyName ( Key : HKEY ) : string;
begin
case Key of
$80000000 : Result:='HKEY_CLASSES_ROOT';
$80000001 : Result:='HKEY_CURRENT_USER';
$80000002 : Result:='HKEY_LOCAL_MACHINE';
$80000003 : Result:='HKEY_USERS';
$80000004 : Result:='HKEY_PERFORMANCE_DATA';
$80000005 : Result:='HKEY_CURRENT_CONFIG';
$80000006 : Result:='HKEY_DYN_DATA';
else
Result:='';
end;
end;

function NormalizeString( s : String ) : String;
var
i : Integer;
subst : String;
begin
SetLength(Result,Length(s)); //Try to minimize reallocations
Result:='';
for i:=1 to Length(s) do
begin
subst:=Substitutions[ord(s[i])];
if subst<>'' then
Result:=Result+subst
else
Result:=Result+s[i];
end;
end;

function ConvertValueToStr(Reg : TRegistry; ValueName : String) : String;
var
DataType : TRegDataType;
DataSize : Integer;
Buffer : pointer;
p : ^byte;
b : byte;
i : Integer;
begin
DataType:=Reg.GetDataType(ValueName);
case DataType of
rdString,
rdExpandString :
Result := '"'+NormalizeString(Reg.ReadString(ValueName))+'"';

rdInteger : Result := Format('dword:%.8x',[Reg.ReadInteger(ValueName)]);

rdBinary : begin
DataSize := Reg.GetDataSize(ValueName);
GetMem(Buffer,Datasize);
try
if Reg.ReadBinaryData(ValueName,Buffer^,Datasize)=Datasize then
begin
Result:='hex:';
p:=Buffer;
for i:=0 to Datasize-1 do
begin
b:=p^;
if i<Datasize-1 then
Result:=Result+Format('%.2x,',[b])
else //the last byte, no comma
Result:=Result+Format('%.2x',[b]);

if (i mod 16 = 15) then
Result:=Result+'\'+#13#10;

inc(p);
end;
end;
finally
Freemem(Buffer,Datasize);
end;
end;
end;
end;

procedure PrepareData(Reg : TRegistry; Data : TStrings );
var
Values : TStringList;
Keys : TStringList;
CurPath : String;
s : String;
i : Integer;
begin
Values := TStringList.Create;
Keys := TStringList.Create;

Keys.Add(Reg.CurrentPath);

try
while Keys.Count>0 do
begin
if Reg.OpenKey('\'+Keys[0],False) then
begin
CurPath:=Reg.CurrentPath;
Reg.GetValueNames(Values);

Data.Add(Format('[%s\%s]',[RegistryRootKeyName(Reg.RootKey),CurPath]));

for i:=0 to Values.Count-1 do
begin
if Values[i]='' then
s:='@'
else
s:='"'+Values[i]+'"';
Data.Add(Format( '%s=%s',
[s,ConvertValueToStr(Reg,Values[i])]));
end;

Data.Add('');

Reg.GetKeyNames(Values); //Use values as temporary storage
for i:=0 to Values.Count-1 do
Keys.Insert(1,Keys[0]+'\'+Values[i]);

Values.Clear;
end;

Keys.Delete(0);
end;
finally
Keys.Free;
Values.Free;
end;
end;

procedure ExportKey ( RootKey : HKEY; Key : String;
FileName : String; Overwrite : Boolean );
var
Reg : TRegistry;
ExportData : TStringList;
Ok : Boolean;
begin
if FileExists(FileName) and not Overwrite then
exit;

Reg := TRegistry.Create;
ExportData := TStringList.Create;
try
Reg.RootKey:=RootKey;
if Reg.OpenKey(Key,False) then
begin
ExportData.Add(ExportHeader);
ExportData.Add('');

PrepareData(Reg,ExportData);

Ok:=not FileExists(FileName);
if not Ok then
Ok:=DeleteFile(FileName);
if Ok then
ExportData.SaveToFile(FileName);
end;
finally
ExportData.Free;
Reg.Free;
end;
end;

initialization
Initialize;


end.
Responder Con Cita