Delphi程序的时限和加密方法

本例中TRegistry是关键类 Delphi 不能自行加入 需在uses部分手工加入 registry 通过其方法 ReadString 和 WriteString 来读出和写入字符 亦可通过其方法 ReadDate 和 WriteDate 来读出和写入日期

程序第一次运行就写入其运行时间 应用期限为 天 超过 天就不再运行 全局变量NoRegistry SpareDays来分别判断是否注册和剩余期限 自定义函数Encrypt为用户名到

密码的变换函数

一 程序启动时 通过搜索注册表 判断是否第一次运行和是否注册 来确定程序是否运行

procedure TForm FormCreate(Sender: TObject)var Reg:TregistryKeyName TempCode TempName TempStr:stringSame:IntegerFirstDate NowDate:TdatetimeNumberOfDays:realbegin NoRegistry:=trueNowDate:=date//取得运行时系统日期try//创建注册表 有该键则读取 无则创建 Reg:=Tregistry Create Reg RootKey :=ey_local_machineKeyName:= Sofarejsjbxample if Reg OpenKey(KeyName true) then begin TempName:=Reg ReadString( UsrName )TempCode:=Reg ReadString( Passwd )//读取用户名 注册号 try FirstDate:=Reg ReadDate( Date )//非第一次则读入第一次运行时间 except Reg WriteDate( Date NowDate)// 若为第一次运行 则写入系统日期 FirstDate:=NowDateendend reg CloseKey finally reg Free endTempStr:=Encrypt(TempName)//通过自定义函数Encrypt()来获取密码 Same:=CompareText(TempStr TempCode)//比较密码 if TempName<>then if Same= then NoRegistry:=false//验证密码 通过NoRegistry为false if NoRegistry then begin //若未注册 NumberOfDays:=Nowdate FirstDateSpareDays:=round( NumberOfDays)Label Caption :=FloatToStr(SpareDays)if((NumberOfDays>) or (NumberOfDays<)) thenbeginshowmessage( 程序未注册超过试用期或更改系统时间 将终止运行! )application Terminate//超过 天 则禁止运行endendend

二 注册过程 其响应入口可放于 About 内

procedure TAbout Button Click(Sender: TObject)var InptName InptCode RealCode:StringSame:IntegerReg:TregistryKeyname:Stringbegin if NoRegistry then //未注册时做 begin RealCode:= InptName:= InputBox( 注册 输入你的名字 )if InptName<>then begin InptCode:= InputBox( 注册 输入注册号 )RealCode:=Encrypt(InptName)Same:=CompareText(RealCode InptCode)if (Same<>) thenshowmessage( 注册号码不对 注册未成功！ ) else begin //密码匹配时做 把用户名 密码写入注册表 TryReg:=Tregistry Create Reg RootKey :=ey_local_machineKeyName:= Sofarejsjbxample if Reg OpenKey(KeyName true) then beginReg WriteString( Passwd InptCode)Reg WriteString( UsrName InptName)endreg CloseKey finally Reg Free endNoRegistry:=false//可修改注册后的界面 endendendend    三 密码的变换函数 此变换函数可由读者自由发挥 在此 仅示一例而已

lishixinzhi/Article/program/Delphi/201311/8395

我用的加密解密

function EncryptString(Source, Key: string): string

//对字符串加密(Source:源 Key:密匙)

var

KeyLen: integer

KeyPos: integer

Offset: integer

Dest: string

SrcPos: integer

SrcAsc: integer

Range: integer

begin

KeyLen := Length(Key)

if KeyLen = 0 then

Key := 'delphi'

KeyPos := 0

Range := 256

randomize

Offset := random(Range)

Dest := format('%1.2x', [Offset])

for SrcPos := 1 to Length(Source) do

begin

SrcAsc := (Ord(Source[SrcPos]) + Offset) mod 255

if KeyPos <KeyLen then

KeyPos := KeyPos + 1

else

KeyPos := 1

SrcAsc := SrcAsc xor Ord(Key[KeyPos])

Dest := Dest + format('%1.2x', [SrcAsc])

Offset := SrcAsc

end

result := Dest

end

function UnEncryptString(Source, Key: string): string

//对字符串解密(Src:源 Key:密匙)

var

KeyLen: integer

KeyPos: integer

Offset: integer

Dest: string

SrcPos: integer

SrcAsc: integer

TmpSrcAsc: integer

begin

KeyLen := Length(Key)

if KeyLen = 0 then

Key := 'delphi'

KeyPos := 0

Offset := strtoint('$' + copy(Source, 1, 2))

SrcPos := 3

repeat

SrcAsc := strtoint('$' + copy(Source, SrcPos, 2))

if KeyPos <KeyLen then

KeyPos := KeyPos + 1

else

KeyPos := 1

TmpSrcAsc := SrcAsc xor Ord(Key[KeyPos])

if TmpSrcAsc <= Offset then

TmpSrcAsc := 255 + TmpSrcAsc - Offset

else

TmpSrcAsc := TmpSrcAsc - Offset

Dest := Dest + chr(TmpSrcAsc)

Offset := SrcAsc

SrcPos := SrcPos + 2

until SrcPos >= Length(Source)

result := Dest

end

我以前也做过这种小程序。这个算法你可以自己设计，也可以用像什么MD5之类的加解密算法咯。

但因为不能粘贴附件，所以就贴点代码。

procedure TForm1.N2Click(Sender: TObject)//打开文件

var

tl:string

begin

if OpenDialog1.Execute then

begin

ListBox1.Clear

Caption:='文件加密解密器'+OpenDialog1.FileName

AssignFile(ATextFile,OpenDialog1.FileName)

Reset(ATextFile)

while not eof(ATextFile) do

begin

Readln(ATextFile,tl)

ListBox1.Items.Add(tl)

end

CloseFile(ATextFile)

end

end

function Encode(s:string):string//加密的核心部分

var

n,i:integer

str:string

begin

n:=length(s)

str:=''

for i:=1 to n do

begin

str:=str+char(ord(s[i])+10)

end

Encode:=str

end

function Decode(s:string):string//解密的核心部分

var

n,i:integer

str:string

begin

n:=length(s)

str:=''

for i:=1 to n do

begin

str:=str+char(ord(s[i])-10)

end

Decode:=str

end

procedure TForm1.N3Click(Sender: TObject)//加密

var

ln:integer

tl,nl:string

begin

if SaveDialog1.Execute then

begin

AssignFile(ATextFile,SaveDialog1.FileName)

Rewrite(ATextFile)

for ln:=0 to ListBox1.Items.Count-1 do

begin

tl:=ListBox1.Items[ln]

nl:=Encode(tl)//加密

Writeln(ATextFile,nl)

end

CloseFile(ATextFile)

end

end

procedure TForm1.N4Click(Sender: TObject)//解密

var

ln:integer

tl,nl:string

begin

if SaveDialog1.Execute then

begin

AssignFile(AtextFile,SaveDialog1.FileName)

Rewrite(ATextFile)

for ln:=0 to ListBox1.Items.Count-1 do

begin

tl:=ListBox1.Items[ln]

nl:=Decode(tl)//解密

Writeln(ATextFile,nl)

end

CloseFile(ATextFile)

end

end

---