{请在Uses中包含Registry单元}
procedure TForm1.Button1Click(Sender:TObject);
var
ARegistry : TRegistry;
begin
ARegistry := TRegistry.Create;
//建立一个TRegistry实例
with ARegistry do
begin
RootKey := HKEY—LOCAL—MACHINE;//指定根键为HKEY—LOCAL—MACHINE
//打开主键Software\Microsoft\Windows\CurrentVersion
if OpenKey( ′Software\Microsoft\Windows\CurrentVersion′,false ) then
begin
memo1.lines.add('Windows版本:′+ ReadString(′Version′));
memo1.lines.add('Windows版本号:′+ ReadString(′VersionNumber′));
memo1.lines.add(′Windows子版本号:′+ ReadString(′SubVersionNumber′));
end;
CloseKey;//关闭主键
Destroy;//释放内存
end;
end;
var
ARegistry : TRegistry;
begin
ARegistry := TRegistry.Create;
//建立一个TRegistry实例
with ARegistry do
begin
RootKey:=HKEY—LOCAL—MACHINE;
if OpenKey(′Software\Microsoft\Windows\CurrentVersion\Run′,True) then
WriteString(′delphi′,′C:\Program Files\borland\delphi3\bin\delphi32.exe′);
CloseKey;
Destroy;
end;
end;
{将程序strExeFileName置为自动启动 }
function StartUpMyProgram ( strPrompt,strExeFileName : string ) : boolean;
var
registerTemp : TRegistry;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software\Microsoft\Windows\CurrentVersion\Run
if OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',True) then
//写入自己程序的快捷方式信息
begin
WriteString( strPrompt, strExeFileName );
result := true;
end
else result := false;
//善后处理
CloseKey;
Free;
end;
end;
{调用StartUpMyProgram,
使Delphi随WINDOWS启动而自动运行 }
procedure TForm1.Button1Click(Sender: TObject);
begin
memo1.lines.add('开始');
if StartUpMyProgram('delphi','C:\Program Files\borland\delphi3\bin\delphi32.exe') then
memo1.lines.add('成功')
else
memo1.lines.add('失败')
end;
---- 应用之二:实现文件关联
当MS WORD 安装在你的系统中时,它会把.DOC 文件与自己关联,当你双击一个DOC 文件,就会启动MS WORD,打开你指定的DOC文件。你也可以把一个文件类型与一个程序关联起来,其秘密还是在注册表中。如果打开注册表,找到HKEY_CLASSES_ROOT,就会发现这里已经有很多文件类型。
你也可以在这里增加一个键,建立自己的文件关联。
{将文件类型strFileExtension与程序
strExeFileName相关联,strDiscription为文件类型说明 }
function AssignToProgram(strFileExtension,strDiscription,strExeFileName : string ) : boolean;
var
registerTemp : TRegistry;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_CLASSES_ROOT;
//设置根键值为HKEY_CLASSES_ROOT
//根据文件类型的扩展名,创建或打开对应的键名.FileExt,如DBF对应'.DBF'
if OpenKey( '.' + strFileExtension, true ) then
begin
result := false;
exit;
end;
//设置键.FileExt默认值为FileExt_Auto_File,如'.DBF'对应'DBF_Auto_File'
WriteString('',strFileExtension + '_Auto_File');
CloseKey;
//写入自己程序的信息
//根据文件类型的扩展名,创建或打开对应的键名
FileExt_Auto_File
//'.DBF'对应'DBF_Auto_File'
if OpenKey(strFileExtension + '_Auto_File', true ) then
begin
result := false;
exit;
end;
//设置默认值文件类型说明,如DBF可对应'xBase数据表'
WriteString('',strDiscription);
CloseKey;
//创建或打开键名FileExt_Auto_File\Shell\open\command,该键为表示操作为'打开'
//'.DBF'对应'DBF_Auto_File\shell\open\command'
if OpenKey(strFileExtension + '_Auto_File\shell\open\command', true ) then
begin
result := false;
exit;
end;
//设置该键的默认值为打开操作对应的程序信息
//如DBF可对应'C:\Program Files\Borland\DBD\DBD32.EXE'
WriteString('',strExeFileName + ' %1');
CloseKey;
Free;
end;
end;
{调用AssignToProgram,使DBF文件与DBD32.EXE关联 }
procedure TForm1.Button3Click(Sender: TObject);
begin
memo1.lines.add('开始');
if AssignToProgram('DBF','xBase数据表','C:\Program Files\borland\dbd\dbd32.exe') then
memo1.lines.add('成功')
else
memo1.lines.add('失败')
end;
{检测系统中是否安装了BDE }
function IsBDEInstalled : boolean;
var
registerTemp : TRegistry;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//查询Software\Borland\Database Engine
result := OpenKey('Software\Borland\Database Engine',false);
//善后处理
CloseKey;
Free;
end;
end;
{调用IsBDEInstalled,检测系统中是否安装了BDE }
procedure TForm1.Button4Click(Sender: TObject);
begin
memo1.lines.add('开始');
if IsBDEInstalled then
memo1.lines.add('已安装了BDE')
else
memo1.lines.add('未安装BDE')
end;
//保存快捷方式的文件
persistfileTemp := shelllinkTemp as IPersistFile;
if S_OK = persistfileTemp.Save( PWChar( strDesktopDirectory ) , false ) then
result := true //保存成功,返回True
else result := false;
end;
{调用CreateShortcutOnDesktop,为Delphi在桌面上建立快捷方式 }
procedure TForm1.Button2Click(Sender: TObject);
begin
memo1.lines.add('开始');
if CreateShortcutOnDesktop('C:\Program Files\borland\delphi3\bin\delphi32.exe','%1') then
memo1.lines.add('成功')
else
memo1.lines.add('失败')
end;
Function dblBackSlash(t:string):string;
var k:longint;
begin
result:=t; {Strings are not allowed to have}
for k:=length(t) downto 1 do {single backslashes}
if result[k]='\' then insert('\',result,k);
end;
Procedure ProcessBranch(root:string); {recursive sub-procedure}
var
values,
keys:tstringlist;
i,j,k:longint;
s,t:string; {longstrings are on the heap, not on the stack!}
begin
writeln(f); {write blank line}
case rootsection of
HKEY_CLASSES_ROOT : s := 'HKEY_CLASSES_ROOT';
HKEY_CURRENT_USER : s := 'HKEY_CURRENT_USER';
HKEY_LOCAL_MACHINE : s := 'HKEY_LOCAL_MACHINE';
HKEY_USERS : s := 'HKEY_USERS';
HKEY_PERFORMANCE_DATA: s := 'HKEY_PERFORMANCE_DATA';
HKEY_CURRENT_CONFIG : s := 'HKEY_CURRENT_CONFIG';
HKEY_DYN_DATA : s := 'HKEY_DYN_DATA';
end;
Writeln(f,'['+s+'\'+root+']'); {write section name in brackets}
reg.OpenKey(root,false);
values := tstringlist.create;
keys:=tstringlist.create;
reg.getvaluenames (values); {get all value names}
reg.getkeynames (keys); {get all sub-branches}
for i:=0 to values.count-1 do {write all the values first}
begin
s := values[i];
t := s; {s=value name}
if s= ''then
s:='@' {empty means "default value", write as @}
else
s:='"' + s + '"'; {else put in quotes}
write(f,dblbackslash(s)+ '=' ); {write the name of the key to the file}
Case reg.Getdatatype(t) of {What type of data is it?}
rdString,
rdExpandString: {String-type}
Writeln(f,'"' + dblbackslash(reg.readstring(t) + '"'));
rdInteger: {32-bit unsigned long integer}
Writeln(f,'dword:' + inttohex(reg.readinteger(t),8));
{ write an array of hex bytes if data is "binary." Perform a line feed after approx. 25 numbers so the line length stays within limits }
rdBinary :
begin
write(f,'hex:');
j := reg.getdatasize(t); {determine size}
getmem(p,j); {Allocate memory}
reg.ReadBinaryData(t,p^,J); {read in the data, treat as pchar}
for k:=0 to j-1 do begin
Write(f,inttohex(byte(p[k]),2)); {Write byte as hex}
if k<>j-1 then {not yet last byte?}
begin
write(f,','); {then write Comma}
if (k>0) and ((k mod 25)=0) then {line too long?}
writeln(f,'\'); {then write Backslash + lf}
end; {if}
end; {for}
freemem(p,j); {free the memory}
writeln(f); {Linefeed}
end;
ELSE
writeln(f,'""'); {write an empty string if datatype illegal/unknown}
end; {case}
end; {for}
reg.closekey;
{value names all done, no longer needed}
values.free;
{Now al values are written, we process all subkeys}
{Perform this process RECURSIVELY...}
for i := 0 to keys.count -1 do
ProcessBranch(root+'\'+keys[i]);
keys.free; {this branch is ready}
end;
begin
if regroot[length(regroot)]='\' then {No trailing backslash}
setlength(regroot,length(regroot)-1);
Assignfile(f,filename); {create a text file}
rewrite(f);
IF ioresult<>0 then
EXIT;
Writeln(f,'REGEDIT4'); {"magic key" for regedit}
reg:=tregistry.create;
try
reg.rootkey:=rootsection;
ProcessBranch(regroot); {Call the function that writes the branch and all subbranches}
finally
reg.free; {ready}
close(f);
end;
end;
end.
2003-11-20 12:22:54 读写网络上其他计算机注册表的代码
procedure NetReg;
var
R: TRegistry;
S: TStringList;
begin
R:=TRegistry.Create;
S:=TStringList.Create;
WriteLn(R.RegistryConnect('\\OtherPC'));
WriteLn(R.OpenKeyReadOnly('Software'));
R.GetKeyNames(S);
WriteLn(S.CommaText);
S.Free;
R.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Reg := TRegistry.Create;
Reg.OpenKey ('\', False);
UpdateAll;
// select the current root(选择当前的根目录)
ComboKey.ItemIndex := 1;
ComboLast.Items.Add('\'); ///////
ComboLast.ItemIndex := 0;
end;
//更新
procedure TForm1.UpdateAll;
begin
Caption := Reg.CurrentPath;
if Caption = ' then
Caption := '[Root]';
if Reg.HasSubKeys then
Reg.GetKeyNames(ListSub.Items)
else
ListSub.Clear;
Reg.GetValueNames(ListValues.Items);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Reg.CloseKey;
Reg.Free;
end;
procedure TForm1.ListSubClick(Sender: TObject);
var
NewKey, Path: string;
nItem: Integer;
begin
// get the selection(获取选择项)
NewKey := ListSub.Items [ListSub.ItemIndex];
Reg.OpenKey (NewKey, False);
// save the current path (eventually adding a \)(在不列出于列表时保存路径)
// only if the it is not already listed
Path := Reg.CurrentPath;
if Path < '\' then
Path := '\' + Path;
nItem := ComboLast.Items.IndexOf (Path);
if nItem < 0 then
begin
ComboLast.Items.Insert (0, Path);
ComboLast.ItemIndex := 0;
end
else
ComboLast.ItemIndex := nItem;
UpdateAll;
end;
procedure TForm1.ComboLastChange(Sender: TObject);
begin
Reg.OpenKey (ComboLast.Text, False);
UpdateAll;
end;
end.
2003-11-20 13:30:00 获得注册表项下的所有值
Var
Reg : TRegistry;
list : TStrings;
i : Integer;
Begin
Reg:=TRegistry.Create;
Reg.RootKey:='HKEY_LOCAL_MACHINE';
If Reg.OpenKey('\Software\Microsoft\CurrentVersion\Run', false) then
Begin
List:=TStringList.Create;
Reg.GetValueNames(List);
For i:=0 to list.Count-1 do
If Reg.ValueExists(List[i]) then
Begin
Case Reg.GetDataType(List[i]) of rdInteger: Reg.ReadInteger(List[i]);
rdBinary: Reg.ReadBinaryData(List[i]);
else
Reg.ReadString(List[i]);
End;
End;
End;
myreg:=Tregistry.Create;
//必须在程序单元的uses部分加入Registry
myreg.RootKey:=HKEY_LOCAL_MACHINE;
if myreg.openkey('software\microsoft\windows\currentversion',false) then
memo1.lines.add(' 注册用户名:'+myreg.readstring('RegisteredOwner'));
myreg.closekey;
以上仅举几例,获取其他一些信息的方法与此类似,详见源程序。
begin
memo1.Lines.Clear;
for ch:='A' to 'Z' do begin
i:=getdrivetype(pchar(ch+':\'));
buffer:=' '+ch+': ';
case i of
DRIVE_UNKNOWN : buffer:=buffer+'未知类型';
DRIVE_REMOVABLE: buffer:=buffer+'软盘';
DRIVE_FIXED : begin
buffer:=buffer+'硬盘';
if getdiskfreespace(pchar(ch+':\'),spc,bps,nofc,tnoc) then begin
buffer:=buffer+'总容量:'+inttostr((spc*bps*tnoc) div (1024*1024))+'MB';
buffer:=buffer+'剩余:'+inttostr((spc*bps*nofc) div (1024*1024))+'MB';
end;
end;
DRIVE_REMOTE : buffer:=buffer+'网络驱动器';
DRIVE_CDROM :buffer:=buffer+'CD-ROM驱动器';
DRIVE_RAMDISK:buffer:=buffer+'RAM虚拟驱动器';
end;
if (ch >'D') and (i=1) then break;
if i< >1 then memo1.Lines.Add(buffer);
end;
case getkeyboardtype(0) of //获取键盘类型
1: buffer:=' 键盘: IBM PC/XT或兼容类型(83键)';
2: buffer:=' 键盘: Olivetti "ICO"(102键)';
3: buffer:=' 键盘: IBM PC/AT(84键)';
4: buffer:=' 键盘: IBM增强型(101或102键)';
5: buffer:=' 键盘: Nokia 1050';
6: buffer:=' 键盘: Nokia 9140';
7: buffer:=' 键盘: Japanese';
end;
memo1.lines.add(buffer);
globalmemorystatus(meminfo); //获取系统内存数量
memo1.lines.add(' 物理内存:'+inttostr(meminfo.dwTotalPhys div 1024)+' KB');
i:=getsystemmetrics(SM_CLEANBOOT);
case i of
0:buffer:='系统启动模式:正常模式';
1:buffer:='系统启动模式:保护模式';
2:buffer:='系统启动模式:网络保护模式';
end;
memo1.lines.add(buffer);
x:=getsystemmetrics(SM_ARRANGE);
//获取系统最小化窗口的起始位置和排列方式
y:=x;
x:=x and 3;
y:=y and 12;
case x of
ARW_BOTTOMLEFT : buffer:=' 最小化窗口:自左下角';
ARW_BOTTOMRIGHT : buffer:=' 最小化窗口:自右下角';
ARW_TOPLEFT : buffer:=' 最小化窗口:自左上角';
ARW_TOPRIGHT : buffer:=' 最小化窗口:自右上角';
end;
case y of
ARW_LEFT : buffer:=buffer+'横向排列';
ARW_UP : buffer:=buffer+'纵向排列';
ARW_HIDE : buffer:=buffer+'隐藏';
end;
memo1.lines.add(buffer);
//从注册表中获取CPU标识,Windows版本,产品标识,注册单位名称及用户名
myreg:=Tregistry.Create;
myreg.RootKey:=HKEY_LOCAL_MACHINE;
if myreg.OpenKey('hardware\description\system\centralprocessor\0',false) then
memo1.lines.add(' CPU标识:'+myreg.ReadString('VendorIdentifier'));
myreg.closekey;
if myreg.openkey('software\microsoft\windows\currentversion',false) then begin
memo1.lines.add(' windows版本:'+myreg.ReadString('Version'));
memo1.lines.add(' 版本号:'+myreg.ReadString('VersionNumber')+''+myreg.ReadString('Subversionnumber'));
memo1.lines.add(' 产品标识:'+myreg.Readstring('ProductID'));
memo1.lines.add('注册单位名称:'+myreg.readstring('RegisteredOrganization'));
memo1.lines.add(' 注册用户名:'+myreg.readstring('RegisteredOwner'));
end;
myreg.CloseKey;
myreg.Free;
end;
end.
2003-11-20 13:44:20 注册表配置ODBC的详细例子
【思路】:先在ODBC中配置然后到注册表中去看有什么增加,然后照样写进去就可以了,但是这样做有一个问题,SQL Server默认是用命名管道,如果要用TCP/IP协议请在注册表中找1433,就能找到它是在那里.照样写进去就OK了。
var
reg : TRegistry;
begin
reg := TRegistry.Create;
//建立一个Registry实例
with reg do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software\ODBC\ODBC.INI\ODBC Data Sources
if OpenKey('Software\ODBC\ODBC.INI\ODBC Data Sources' True) then
begin
//注册一个DSN名称
WriteString( 'DSN' 'SQL Server' );
end
else
begin
//创建键值失败
ShowMessage('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software\ODBC\ODBC.INI\masdsn 写入DSN配置信息
if OpenKey('Software\ODBC\ODBC.INI\DSN' True) then
begin
WriteString( 'Driver' 'C:\Windows\System\sqlsrv32.dll' );
WriteString( 'LastUser' 'Username' );
WriteString( 'Password' 'password' );
WriteString( 'Server' 'ServerName' );
end
else
//创建键值失败
begin
Showmessage('增加ODBC数据源失败');
exit;
end;
CloseKey;
Free;
ShowMessage('增加ODBC数据源成功');
end;
type
TFontRegData = record
Name : string[100];
Size : integer;
Color : TColor;
Style : set of TFontStyle;
Charset : byte;
Height : integer;
Pitch : TFontPitch;
PixelsPerInch : integer;
end;
// Before writing font data to the registry you have to copy all needed data to a record of fixed size
procedure PrepareFontDataForRegistry(Font : TFont;var RegData : TFontRegData);
begin
{ Copy font data to record for saving to registry }
//复制字体数据到记录并保存到注册表中
with RegData do
begin
Name:=Font.Name;
Size:=Font.Size;
Color:=Font.Color;
Style:=Font.Style;
Charset:=Font.Charset;
Height:=Font.Height;
Pitch:=Font.Pitch;
PixelsperInch:=Font.PixelsPerInch;
end;
end;
procedure PrepareFontfromRegData(Font : TFont;RegData : TFontRegData);
begin
{ Set font data to values read from registry }
//设置来自注册表的字体数据的值
with Font do
begin
Name:=RegData.Name;
Size:=RegData.Size;
Color:=RegData.Color;
Style:=RegData.Style;
Charset:=RegData.Charset;
Height:=RegData.Height;
Pitch:=RegData.Pitch;
PixelsperInch:=RegData.PixelsPerInch;
end;
end;
//初始化
procedure TForm1.FormCreate(Sender: TObject);
begin
Font:=TFont.Create;
Font.Name:='Arial';
end;
begin
Reg:=TRegistry.Create;
Reg.OpenKey('Software\Test',true);
if Reg.ValueExists('FontData') then
Reg.ReadBinaryData('FontData',rd,Sizeof(rd));
reg.Free;
PrepareFontFromRegData(Font,rd);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Font.Free;
end;
一、程序启动时,通过搜索注册表,判断是否已有密码,来确定窗口的显示内容。不过事先应有以下的声明然后才能使用:
在user中加入TRegistry,在var声明中加入以下几个窗体变量:
var
TheReg: TRegistry;
KeyName,ValueStr,tempStr:String;
procedure TfrmPass.FormShow(Sender: TObject);
begin
TheReg := TRegistry.Create;
try TheReg.RootKey := HKEY-LOCAL-MACHINE;
KeyName := ′SOFTWARE\Mypassword′;
//有该键则打开,没有则创建
if TheReg.OpenKey(KeyName, True) then begin
tempStr:=ExtractFileName(Application.ExeName); //读取密码
ValueStr:=TheReg.ReadString(tempStr);
//密码不为空则修改窗体为验证密码
if ValueStr<>′′ then begin
edit2.Visible:=false; frmPass.Caption:=′验证密码′;
edit1.SetFocus; OK.Caption:=′确定′;
end
//密码为空则修改窗体为设置密码对话框
else begin
showmessage(′第一次使用请设置密码!′);
edit2.Visible:=true; frmPass.Caption:=′请设置新密码′;
edit1.SetFocus; OK.Caption:=′设置′;
end;
TheReg.CloseKey;
end;
finally
TheReg.Free;
end;
end;
二、按钮的响应代码:包括新设密码和验证密码。
procedure TfrmPass.OKClick(Sender: TObject);
begin
//根据Edit2的显示与否判断已有密码,进行验证
if edit2.Visible=false then begin
if pass(edit1.text)=ValueStr then begin
showmessage(′密码正确!′);
end
else begin
showmessage(′密码不正确!无权操作!′);
halt;
end;
end //无密码,设置新密码
else begin
if edit1.text=edit2.text then begin
TheReg := TRegistry.Create;
TheReg.RootKey := HKEY-LOCAL-MACHINE;
KeyName := ′SOFTWARE\Mypassword′;
if TheReg.OpenKey(KeyName, True) then
TheReg.WriteString(tempStr,pass(edit1.text));
TheReg.CloseKey;
end
else begin
showmessage(′再次键入的密码不一致,请重输!′);
edit1.text:=′′; edit2.text:=′′;
edit1.SetFocus;
end; //进行下一步操作...
end;
end;
三、密码变换程序:注意要预先定义。
这个变换小程序在笔者看来还不算很复杂,只进行了两次变换,不过,想要破译也是得费点劲。读者还可以采用其他的数学函数进行更为复杂的变换。
function pass(pstr:string):string;
var str,str1:string;
i,j:integer;
begin
str:=pstr;
for i:=1 to length(str) do begin
//进行第一次变换
j:=(i*i*i mod (i+20))+(i*i mod (i+10))+i*2+1;
str1:=str1+chr(ord(str[i])+j); //第二次变换
j:=(i*i*i mod (i+10))+(i*i mod (i+20))+i*2+1;
str1:=str1+chr(ord(str[i])+j); end;
pass:=str1;
end;
1.在HKEY_LOCAL_MACHINE\Software\ODBC\ODBC.INI\ODBC Data Sources中增加一个字符串
键值,为MyAccess = Microsoft Access Driver(*.mdb),其中分别为数据源名称和数据库类型.
这是在注册表中注册一个系统DSN名称.
{*******************************************************
在本程序中,将创建一个ODBC系统数据源(DSN),
数据源名称:MyAccess 数据源描述:我的新数据源
数据库类型:ACCESS97
对应数据库:C:\Inetpub\wwwroot\test.mdb
*******************************************************}
{ 注意应在USES语句中包含Registry }
procedure TForm1.Button1Click(Sender: TObject);
var
registerTemp : TRegistry;
bData : array[ 0..0 ] of byte;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software\ODBC\ODBC.INI\ODBC Data Sources
if OpenKey('Software\ODBC\ODBC.INI\ODBC Data Sources',True) then
begin //注册一个DSN名称
WriteString( 'MyAccess', 'Microsoft Access Driver (*.mdb)' );
end
else
begin//创建键值失败
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
假设软件的主程序窗口为FORM1,则将该段代码置放在FORM1.Create事件中。代码如下:
procedure TForm1.form1create(Sender: TObject);
var
re_id:integer;
registerTemp : TRegistry;
inputstr,get_id:string;
dy,clickedok:boolean;
begin
dy:=false; //软件是否已到注册期、及是否允许继续使用的标志,当值为FALSE是为允许使
用。
registerTemp := TRegistry.Create; //准备使用注册表
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE; //存放在此根下
if OpenKey('Software\Microsoft\Windows\CurrentVersion\Mark',True) then
// 建一目录,存放标志值。当然也可以存放在已存在的目录下。怎么样,很难发现吧?
begin
if valueexists('gc_id') then begin
//用gc_id的值作为标志,首先判断其存在否?
re_id:=readinteger('gc_id');//读出标志值
if (re_id<>0) and (re_id<>100) then begin
//若标志值为0,则说明已注册。
//若不为0且值不到100,说明虽未注册,但允许使用的次数尚未达到。
re_id:=re_id+5;
//允许标志的最大值为100,每次加5,则最多只可用20次。
Writeinteger('gc_id',re_id);//将更新后的标志值写入注册表中。
end;
if re_id=100 then dy:=true; //假如值已到100,则应注册。
end
else Writeinteger('gc_id',5);//建立标志,并置初始标志值。
end;
if dy then begin //若dy值为TRUE,则应提示用户输入注册码,进行注册。
clickedok:=InputQuery('您使用的是非注册软件,请输入注册码:',' ',inputstr);
if clickedok then begin
get_id:=inttostr(27593758*2);//注册码为55187516,当然可加入更杂的算法。
if get_id=inputstr then begin
Writeinteger('gc_id',0);
//若输入的注册码正确,则将标志值置为0,即已注册。
CloseKey;
Free;
end
else begin //若输入的注册码错误,应作出提示并拒绝让其继续使用
application.messagebox('注册码错误!请与作者联系!','警告框',mb_ok);
CloseKey;
Free;
application.terminate; //中止程序运行,拒绝让其继续使用
end;
end
else begin //若用户不输入注册码,也应作出提示并拒绝让其继续使用
application.messagebox('请与作者联系,使用注册软件!','警告框',mb_ok);
CloseKey;
Free;
application.terminate;
end;
end;
end;
end;
【问题】:
通过对注册表进行修改,可以删除资源管理器上下文件菜单中对某类文件的处理命令程序例如下:
procedure FileTDelAction(key, name: String);
//key:关联键值为后缀的描述键值,如.tst对应testfile,则key:=testfile
//name:命令名称
var
myReg: TRegistry;
begin
myReg:=TRegistry.Create;
myReg.RootKey:=HKEY_CLASSES_ROOT;
//如果给出的是一个文件后缀,则转换成对应的描述键值
//在生成文件关联时,如果未给出描述键值,则会自动生成,此处与上面是联系的
{if key[1] = '.' then
key:= copy(key,2,maxint)+'_auto_file';}
if key[1] = '.' then
begin
if myReg.KeyExists(key) then //首先看注册表中是否有此键,有则取出
begin
myReg.OpenKey(key, false);
key:=myReg.ReadString ('');
end
else
key:= copy(key,2,maxint)+'_auto_file';
end;
if key[Length(key)-1] <> '\' then
key:=key+'\';
myReg.OpenKey('\'+key+'shell\', true);
if myReg.KeyExists(name) then
myReg.DeleteKey(name);
myReg.CloseKey;
myReg.Free;
end;
Procedure Tform1.SpeedButton1Click(Sender:Tobject);
Begin
If (filelistbox1.FileName=′′) Then {判断Filelistbox1中文件有没有被选中}
Messagedlg(′请先选择一幅位图′,mtInformation,[mbOK],0)
Else
Image1.Picture.LoadFormFile(Filelistbox1.FileName);{加载图片文件并显示}
End;
ProcedureTform1.SpeedButton2Click(Sender:TObject);
Var
Reg:Tregistry;
{Tregistry 对象在Registry 单元中声明,需用Uses令引用Registry单元}
}
Begin
If (Filelistbox1.FileName=′′) Then
Messagedlg(′请先选择一幅位图′,mtinformation,[mbOK],0)
Else
Begin
Reg:=Tregistry.Create;{创建Tregistry对象的实例}
Reg.Rootkey:= Hkey_Current_User;{设置根键名称}
Reg.OpenKey′Control Panel\Desktop′,False);
{打开Control Panel\Desktop路径对应的主键}
Reg.WriteString (′TileWallPaper′, ′0′);
Reg.WriteString ′Wallpaper′,fileli?stbox1.FileName);
{向TileWallpaper 和Wallpaper串覆盖写入新值}
Systemparametersinfo(SPI_SETDESKWallpaper,0,Nil,SPIF_SendChange);
{向Windows发送消息,通知Windows更换壁纸}
Reg.CloseKey;{将更改内容写入注册表并关闭}
Reg.Free;{释放对象}
End;
End;
代码中用到的一些函数可以察看Delphi的联机帮助。需要注意的是:调用打开子键的函数OpenKey时,第二个参数一定要设为False。
通过对注册表进行修改,可以在资源管理器上下文菜单中增加对某类文件的处理命令程序例如下:
procedure FileTAddAction(key, name, display, action: String);
//key:关联键值为后缀的描述键值,如.tst对应testfile,则key:=testfile
//name:命令名称
//display:在上下文件菜单上显示的提示信息
//action:对应的命令
var
myReg:TRegistry;
begin
myReg:=Tregistry.Create;
myReg.RootKey:=HKEY_CLASSES_ROOT;
if name='' then name:=display;
//如果给出的是一个文件后缀,则转换成对应的描述键值
//在生成文件关联时,如果未给出描述键值,则会自动生成,此处与上面是联系的
{ if key[1] = '.' then
key:= copy(key,2,maxint)+'_auto_file';}
if key[1] = '.' then
begin
if myReg.KeyExists(key) then //首先看注册表中是否有此键,有则取出
begin
myReg.OpenKey(key, false);
key:=myReg.ReadString ('');
end
else
key:= copy(key,2,maxint)+'_auto_file';
end;
if key[Length(key)-1] <> '\' then
key:=key+'\';
if name[Length(name)-1] <> '\' then
name:=name+'\';
myReg.OpenKey(key+'Shell\'+name, true);
myReg.WriteString('', display);
MyReg.CloseKey;
MyReg.OpenKey(key+'Shell\'+name+'Command\', true);
MyReg.WriteString('', action);
myReg.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
fRegistry := TRegistry.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fRegistry.Free;
end;
procedure TForm1.DoAnalyzeRegistry;
begin
fStopFlag := FALSE;
fNoSelection := TRUE;
if not fStopFlag then
begin
fCurrentKeyValue := 'HKEY_CURRENT_USER';
fRegistry.RootKey := HKEY_CURRENT_USER;
fRegistry.OpenKey('\', FALSE);
DoAnalyzeBranch();
end;
if not fStopFlag then
begin
fCurrentKeyValue := 'HKEY_USERS';
fRegistry.RootKey := HKEY_USERS;
fRegistry.OpenKey('\', FALSE);
DoAnalyzeBranch();
end;
if not fStopFlag then
begin
fCurrentKeyValue := 'HKEY_LOCAL_MACHINE';
fRegistry.RootKey := HKEY_LOCAL_MACHINE;
fRegistry.OpenKey('\Software', FALSE);
DoAnalyzeBranch();
end;
if fRowCount = 1 then
begin
MessageDlg('No invalid references detected.',mtInformation,[mbOK],0);
btnRemove.Enabled := FALSE;
end
else
begin
btnRemove.Enabled := TRUE;
end;
end;
procedure TForm1.DoAnalyzeBranch;
var
I: Integer;
Keys: TStringList;
Path: String;
begin
Keys := TStringList.Create;
try
Path := fRegistry.CurrentPath;
fRegistry.GetKeyNames(Keys);
for I := 0 to Keys.Count - 1 do
begin
if fRegistry.OpenKey(Keys[I], FALSE) then
begin
DoAnalyzeKey(Keys[I]);
if fStopFlag then Break;
if fRegistry.HasSubKeys then DoAnalyzeBranch;
end;
if fStopFlag then Break;
NormalizeRegistryPath(Path);
if not fRegistry.OpenKey(Path, FALSE) then
raise exception.Create('Can not open key '+Path);
end;
finally
Keys.Free;
end;
end;
procedure TForm1.DoAnalyzeKey(const Key: String);
var
I: Integer;
Values: TStringList;
DataType: TRegDataType;
StringValue: String;
RegKeyInfo: TRegKeyInfo;
SystemTime: TSystemTime;
StringDate: String;
begin
Values := TStringList.Create;
try
fRegistry.GetValueNames(Values);
for I := 0 to Values.Count - 1 do
begin
DataType := fRegistry.GetDataType(Values[I]);
if (DataType = rdString) or (DataType = rdExpandString) then
begin
StatusBar1.SimpleText := 'Analyzing: '+Key;
{ Let the applocation to process messages,
so the text would be on the status bar
while we are still in the loop }
Application.ProcessMessages;
if fStopFlag then Break;
StringValue := fRegistry.ReadString(Values[I]);
if (not DoAnalyzeValue(Key, Values[I])) or
(not DoAnalyzeValue(Key, StringValue)) then
begin
if StringGrid1.RowCount = fRowCount then
StringGrid1.RowCount := fRowCount + 10;
{ If there is no rows selected yet then select the first one }
if fNoSelection then
begin
fNoSelection := FALSE;
StringGrid1.Selection := TGridRect(Rect(0, 1, 4, 1));
end;
function TForm1.DoAnalyzeValue(const Key, Value: String): Boolean;
var
DriveType: UINT;
Path: String;
FileName: String;
begin
Result := TRUE;
{ Verify if the string can be treated as path (and file name)}
if Length(Value) < 3 then Exit;
if not (UpCase(Value[1]) in ['C'..'Z']) then Exit;
if Pos(';', Value) > 0 then Exit;
if Pos(',', Value) > 0 then Exit;
if Pos(' ', Value) > 0 then Exit;
if (Value[2] <> ':') or (Value[3] <> '\') then Exit;
Root[0] := Value[1];
DriveType := GetDriveType(Root);
if (DriveType = DRIVE_FIXED) then
begin
if (ExtractFileExt(Value) = '') then
begin
{ No extension, try to treat the value as path }
Path := Value;
if (Path[Length(Path)] <> '\') then
Path := Value + '\';
if not SetCurrentDirectory(PChar(Path)) then
begin
Result := FALSE;
Exit;
end;
end
else
begin
Path := ExtractFilePath(Value);
if not SetCurrentDirectory(PChar(Path)) then
begin
Result := FALSE;
Exit;
end;
FileName := ExtractFileName(Value);
if (GetFileAttributes(PChar(Value)) = -1) then
begin
Result := FALSE;
Exit;
end;
end;
end;
end;
if Key = 'HKEY_CURRENT_USER' then
RootKey := HKEY_CURRENT_USER
else if Key = 'HKEY_USERS' then
RootKey := HKEY_USERS
else if Key = 'HKEY_LOCAL_MACHINE' then
RootKey := HKEY_LOCAL_MACHINE;
end;
if Count = 1 then
Msg := 'Are you sure you want to remove selected entry from the Registry?'
else
Msg := 'Are you sure you want to remove ' +
IntToStr(Selection.Bottom - Selection.Top + 1) +
' selected entries from the Registry?';
if MessageDlg(Msg, mtWarning, [mbYes,mbNo], 0) = mrYes then
begin
for I := Selection.Top to Selection.Bottom do
begin
ParseKeyValue(StringGrid1.Cells[nKeyName, I]);
fRegistry.RootKey := RootKey;
if not fRegistry.OpenKey(Path, FALSE) then
raise Exception.Create('Error opening registry key '+Path);
procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col, Row: Integer;
var CanSelect: Boolean);
begin
{ Display values in the edit controls
only when there is any data in the grid }
if not (fNoSelection) then
begin
edKey.Text := StringGrid1.Cells[nKeyName, Row];
edTime.Text := StringGrid1.Cells[nFileTime, Row];
edValueName.Text := StringGrid1.Cells[nValueName, Row];
edValue.Text := StringGrid1.Cells[nValueString, Row];
end;
end;
procedure TForm1.btnStopClick(Sender: TObject);
begin
{ Set the stop flag, so the registry scanning process can stop }
fStopFlag := TRUE;
end;
end.
2003-12-15 16:21:10 这个程序可以获得注册表下的全部值(另外一种方法)
Var Reg : TRegistry;
list : TStrings;
i : Integer;
Begin
Reg:=TRegistry.Create;
Reg.RootKey:='HKEY_LOCAL_MACHINE';
If Reg.OpenKey('\Software\Microsoft\CurrentVersion\Run', false) then
Begin
List:=TStringList.Create;
Reg.GetValueNames(List);
For i:=0 to list.Count-1 do
If Reg.ValueExists(List[i]) then
Begin
Case Reg.GetDataType(List[i]) of
rdInteger: Reg.ReadInteger(List[i]);
rdBinary: Reg.ReadBinaryData(List[i]);
else
Reg.ReadString(List[i]);
End;
End;
End;
End;