www.pudn.com > HgzVip1.2_code.rar > APFUnit.pas
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('><');}
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.