Regeditcomponent


            //www.dronymc.cjb.net
//drony@mynet.com
// icq:266148308
//Delphi 7 ile sorunsuz çalışmaktadır.
vaktinde bu componentin yaptığı işi yapabilmesi için uzun uzun ve complex kodlar yazıp kafayı yemiştim.
ama sizi artık bu dertten kurtarıyorum (bu arada componentin programcısı el ispanyo, ispanyolca(portekiz ispanyolcası) yapmış manyak
walla gözüm karardı telif hakkı falan demeden ingilizceye çevirdim.(isteyen portekizcede kullanabilir)
unit RegCheckBox;
interface
uses
 Windows, Messages, SysUtils, Classes, Controls, StdCtrls,
 Dialogs,
 Variants,
 Registry;
const
 MAX_BUFFER = 20;
 CompCaption = 'RegCheck';
var
 Quantidade : LongInt=0;
 Buffer : Array[0..MAX_BUFFER-1] of Byte;
 Tamanho : Integer;
 ArqConf : String;
 DebugarErros : Boolean=True;
type
 TLanguage = (PORT,ENG);
 TRootKeys = (HKCU,HKLM,HKCR);
 TKeyType = (BOOL,INT,STR,BIN);
 TString1 = String[1];
 // Define witch language will be used. Default : Portuguese. To use english,
 // delete or put a comment to this definitition
{$DEFINE INCLUDEMESSAGES} // Define se deseja compilar as mensagens de aviso ou erros. Exclua essa linha se deseja
 // um arquivo executável menor.
 // Define if the erros messages will be compiled. Exclude this line or definition
 // if a small code is necessary.
 TRegCheckBox = class(TCheckBox)
 private
 { Private declarations }
 pID : String;
 pSempreCriaChave : Boolean;
 pRootKey : HKEY;
 pRootKeyTemp : TRootKeys;
 pCaminhoDaChave : String;
 pNomeChave : String;
 pValor : Variant;
 pTipoDado : TKeyType;
 pCondicao : String;
 procedure SetRootKey(lRootKey : TRootKeys);
 procedure SetTipoDado(Valor : TKeyType);
 procedure AlteraChave;
 protected
 { Protected declarations }
 procedure Click; override;
 public
 { Public declarations }
 constructor Create(AOwner : TComponent); override;
 destructor Destroy; override;
 function LerConteudoDaChave : Variant;
 published
 { Published declarations }
 property a_RootKey : TRootKeys read pRootKeyTemp write SetRootKey stored True default HKCU;
 property a_ID : String read pID write pID;
 {$IFDEF USEPORTUGUESE}
 property a_SempreCriaChave : Boolean read pSempreCriaChave write pSempreCriaChave stored True default False;
 property a_CaminhoDaChave : String read pCaminhoDaChave write pCaminhoDaChave;
 property a_NomeChave : String read pNomeChave write pNomeChave;
 property a_Valor : Variant read pValor write pValor;
 property a_TipoDeDado : TKeyType read pTipoDado write SetTipoDado;
 property a_Condicao : String read pCondicao write pCondicao;
 {$ELSE}
 property a_AllwaysCreateKey : Boolean read pSempreCriaChave write pSempreCriaChave stored True default False;
 property a_KeyPath : String read pCaminhoDaChave write pCaminhoDaChave;
 property a_KeyName : String read pNomeChave write pNomeChave;
 property a_Value : Variant read pValor write pValor;
 property a_DataType : TKeyType read pTipoDado write SetTipoDado;
 property a_Condition : String read pCondicao write pCondicao;
 {$ENDIF}
 end;
procedure Register;
implementation
uses
 Forms;
var
 Proprietario : TForm;
 Reg : TRegistry;
constructor TRegCheckBox.Create(AOwner : TComponent);
begin
 inherited Create(AOwner);
 Proprietario := TForm(AOwner);
 Inc(Quantidade);
 pID := IntToStr(Quantidade);
 Caption := CompCaption + pID;
 SetRootKey(pRootKeyTemp);
end;
destructor TRegCheckBox.Destroy;
begin
 inherited Destroy;
 Dec(Quantidade);
 pID := IntToStr(Quantidade);
end;
procedure TRegCheckBox.Click;
begin
 inherited Click;
 if (pRootKey <> 0) and (pCaminhoDaChave <> '') and (pNomeChave <> '') then
 if (Proprietario.Active) then
 AlteraChave
 else
 else
 {$IFDEF INCLUDEMESSAGES}
 if (Proprietario.Active) and (DebugarErros) then
 {$IFDEF USEPORTUGUESE}
 ShowMessage('Não é possível tentar fazer alguma alteração se não for especificado uma chave!' + #13#10 +
 'Componente: ' + Name);
 {$ELSE}
 ShowMessage('Its not possible to alter a key if no key value was especified!' + #13#10 +
 'Component: ' + Name);
 {$ENDIF}
 {$ENDIF}
end;
procedure TRegCheckBox.AlteraChave;
begin
 if pValor <> NULL then
 try
 Reg.RootKey := pRootKey;
 Reg.CloseKey;
 if Reg.OpenKey(pCaminhoDaChave,True) then
 begin
 case pTipoDado of
 BOOL : Reg.WriteBool(pNomeChave,Boolean(pValor));
 INT : Reg.WriteInteger(pNomeChave,pValor);
 STR : Reg.WriteString(pNomeChave,pValor);
 BIN : Reg.WriteBinaryData(pNomeChave,Buffer,Tamanho);
 end;
 Reg.CloseKey; // Finalmente, fecha a chave.
 end;
 except
 {$IFDEF INCLUDEMESSAGES}
 if (Proprietario.Active) and (DebugarErros) then
 {$IFDEF USEPORTUGUESE}
 ShowMessage('Ocorreu algum erro quando estava tentando abrir a chave.' + #13#10 +
 'Possivelmente algum programa ou o SO está bloqueando o acesso a esta chave.');
 {$ELSE}
 ShowMessage('An error occurred when trying to open a key.' + #13#10 +
 'Possibly another program is blocking de access to the key.');
 {$ENDIF}
 {$ENDIF}
 end;
end;
function TRegCheckBox.LerConteudoDaChave : Variant;
var
 ValExist : Boolean;
 Operador : String[1];
 OperadorSTR : Array[0..1] of TString1;
 ValCondicao : Integer;
 procedure GetBool;
 begin
 pValor := Reg.ReadBool(pNomeChave);
 end;
 procedure GetInteger;
 begin
 pValor := Reg.ReadInteger(pNomeChave);
 end;
 procedure GetString;
 begin
 pValor := Reg.ReadString(pNomeChave);
 end;
 procedure GetBinary;
 begin
 Tamanho := Reg.GetDataSize(pNomeChave);
 if Tamanho > MAX_BUFFER then
 {$IFDEF INCLUDEMESSAGES}
 if (Proprietario.Active) and (DebugarErros) then
 {$IFDEF USEPORTUGUESE}
 ShowMessage('Erro na leitura do valor binário:' + #13#10#13#10 +
 'Chave: ' + pCaminhoDaChave + '\' + pNomeChave + #13#10 +
 'Quantidade de dados: ' + IntToStr(Tamanho) + #13#10 +
 'Comprimento do Buffer: ' + IntToStr(MAX_BUFFER) )
 {$ELSE}
 ShowMessage('Error reading binary value:' + #13#10 +
 'Key: ' + pCaminhoDaChave + '\' + pNomeChave + #13#10 +
 'Data Lenght: ' + IntToStr(Tamanho) + #13#10 +
 'Buffer Length : ' + IntToStr(MAX_BUFFER) )
 {$ENDIF}
 {$ENDIF}
 else
 else
 Result := Reg.ReadBinaryData(pNomeChave,Buffer,Tamanho) = Tamanho;
 end;
begin
 ValExist := False;
 try
 Checked := False;
 Reg.RootKey := pRootKey;
 Reg.CloseKey;
 if Reg.OpenKey(pCaminhoDaChave,pSempreCriaChave) then
 begin
 try
 if Reg.ValueExists(pNomeChave) then
 begin
 ValExist := True;
 case pTipoDado of // Dá preferência ao tipo de dado selecionado no Object Inspector
 BOOL : GetBool;
 INT : GetInteger;
 STR : GetString;
 BIN : GetBinary;
 end;
 end
 else
 {$IFDEF INCLUDEMESSAGES}
 if (Proprietario.Active) and (DebugarErros) then
 if (pCaminhoDaChave <> '') and (pNomeChave <> '') then
 {$IFDEF USEPORTUGUESE}
 MessageBox(Self.Handle,PChar('Caminho: ' + pCaminhoDaChave + ' ' + pNomeChave),
 PChar('Erro no componente ' + Name + ' . Valor não existe.'),MB_ICONWARNING + MB_OK)
 {$ELSE}
 MessageBox(Self.Handle,PChar('Path: ' + pCaminhoDaChave + ' ' + pNomeChave),
 PChar('Component ' + Name + ' . Value do not exists.'),MB_ICONWARNING + MB_OK)
 {$ENDIF}
 else
 {$IFDEF USEPORTUGUESE}
 MessageBox(Self.Handle,'Não foi especificado uma chave para leitura/escrita do registro.',
 PChar('Erro no componente ' + Name),MB_ICONERROR + MB_OK);
 {$ELSE}
 MessageBox(Self.Handle,'The value for read/write was not especified.',
 PChar('Component ' + Name),MB_ICONERROR + MB_OK);
 {$ENDIF}
 {$ENDIF}
 except
 if ValExist then // Se o valor existe, tenta fazer outro tipo de leitura
 try
 try
 case Reg.GetDataType(pNomeChave) of
 rdInteger : GetInteger;
 rdString : GetString;
 rdBinary : GetBinary;
 end;
 finally
 if VarType(pValor) = varInteger then
 if (pValor = 1) or (pValor = 0) then
 begin
 pValor := Boolean(pValor);
 Checked := pValor;
 end;
 end;
 except
 {$IFDEF INCLUDEMESSAGES}
 if (Proprietario.Active) and (DebugarErros) then
 {$IFDEF USEPORTUGUESE}
 ShowMessage('Não foi possível fazer a leitura da chave: ' + #13#10 +
 pCaminhoDaChave + '\' + pNomeChave + ' no componente ' + Name + #13#10 +
 'Provavelmente deve ser algum tipo de valor desconhecido. Implementar outro tipo de leitura.');
 {$ELSE}
 ShowMessage('Error reading key: ' + #13#10 +
 pCaminhoDaChave + '\' + pNomeChave + ' in component ' + Name + #13#10 +
 'Probably the value of the reading results in an unknown type. Implement another type of reading.');
 {$ENDIF}
 {$ENDIF}
 end;
 end;
 end;
 finally
 if pCondicao <> '' then
 begin
 case pTipoDado of
 INT : begin
 try
 Operador := Copy(pCondicao,1,1); // Extrai operador
 ValCondicao := StrToInt(Copy(pCondicao,2,Length(pCondicao)));
 if Operador = '>' then
 Checked := ValCondicao > pValor
 else
 if Operador = '<' then
 Checked := ValCondicao < pValor
 else
 if Operador = '=' then
 Checked := ValCondicao = pValor
 else
 Checked := ValCondicao <> pValor;
 except
 end;
 end;
 STR : begin
 try
 OperadorSTR[0] := Copy(pCondicao,1,1);
 OperadorSTR[1] := Copy(pCondicao,2,1);
 if UpperCase(OperadorSTR[0]) = 'I' then // Case insensitive
 begin
 if OperadorSTR[1] = '=' then
 Checked := UpperCase(pValor) = UpperCase(Copy(pCondicao,3,Length(pCondicao)))
 else
 Checked := UpperCase(pValor) <> UpperCase(Copy(pCondicao,3,Length(pCondicao)));
 end
 else // Case sensitive
 begin
 if OperadorSTR[1] = '=' then
 Checked := pValor = Copy(pCondicao,3,Length(pCondicao))
 else
 Checked := pValor <> Copy(pCondicao,3,Length(pCondicao));
 end;
 except
 end;
 end;
 BOOL: begin
 Result := pValor;
 Checked := pValor;
 end;
 end;
 end;
 if pTipoDado <> BIN then
 Result := pValor;
 Reg.CloseKey;
 end;
end;
procedure TRegCheckBox.SetRootKey(lRootKey : TRootKeys);
begin
// if pRootKeyTemp <> lRootKey then
// begin
 case lRootKey of
 HKCU : pRootKey := HKEY_CURRENT_USER;
 HKLM : pRootKey := HKEY_LOCAL_MACHINE;
 HKCR : pRootKey := HKEY_CLASSES_ROOT;
 end;
 pRootKeyTemp := lRootKey;
 Invalidate;
// end;
end;
procedure TRegCheckBox.SetTipoDado(Valor : TKeyType);
begin
 FillChar(Buffer,SizeOf(Buffer),0);
 pTipoDado := Valor;
 case Valor of
 BOOL : begin
 pValor := False;
 pCondicao := '';
 end;
 STR : begin
 pValor := '';
 pCondicao := '';
 end;
 INT,BIN : begin
 pValor := 0;
 pCondicao := '';
 end;
 end;
end;
procedure Register;
begin
 RegisterComponents('Plus', [TRegCheckBox]);
end;
initialization
 ArqConf := ExtractFileDir(Application.ExeName) + Application.Name;
 Quantidade := 0;
 Reg := TRegistry.Create;
finalization
 Reg.CloseKey;
 Reg.Free;
 Reg := nil;
end.
System Delphi
