Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName AsString, ByVal pVolumeNameBuffer AsString, ByVal nVolumeNameSize AsLong, lpVolumeSerialNumber AsLong, lpMaximumComponentLength AsLong, lpFileSystemFlags AsLong, ByVal lpFileSystemNameBuffer AsString, ByVal nFileSystemNameSize AsLong) PrivateConst MAX_FILENAME_LEN =256 PrivateConst GETSERIALPASSWORD ="lxy" PublicFunction DriveSerial(ByVal sDrv AsString) AsLong'得到硬盘的序列号 Dim RetVal AsLong Dim str AsString* MAX_FILENAME_LEN Dim str2 AsString* MAX_FILENAME_LEN Dim a AsLong Dim b AsLong Call GetVolumeInformation(sDrv &":", str, MAX_FILENAME_LEN, RetVal, a, b, str2, MAX_FILENAME_LEN) DriveSerial = RetVal End Function PublicFunction GetApplySerial() AsLong'根据c盘的序列号生成一个申请码 GetApplySerial = DriveSerial("c") If GetApplySerial <0Then GetApplySerial =0- GetApplySerial End Function '根据申请码和密码表及密码得到序列号 PublicFunction getSerial(ByVal SRC AsLong, ByVal PASSWORD AsString) AsString Dim SourceString AsString Dim NewSRC AsLong For I =0To30 If (SRC And2^ I) =2^ I Then SourceString = SourceString +"1" Else SourceString = SourceString +"0" EndIf Next I If SRC <0Then SourceString = SourceString +"1" Else SourceString = SourceString +"0" EndIf Dim Table AsString '========================================================================== '参数Table是密码表,根据你的要求换成别的,不过长度要一致 '========================================================================== '注意:这里的密码表变动后,对应的注册号生成器的密码表也要完全一致才能生成正确的注册号 Table ="JSDJFKLUWRUOISDH;KSADJKLWQ;ABCDEFHIHL;KLADSDKJAGFWIHERQOWRLQH" '========================================================================== Dim TableIndex AsInteger Dim Result AsString Dim MidWord AsString Dim MidWordValue AsByte Dim ResultValue AsByte For t =1To1 For I =1ToLen(SourceString) MidWord =Mid(SourceString, I, 1) MidWordValue =Asc(MidWord) TableIndex = TableIndex +1 If TableIndex >Len(Table) Then TableIndex =1 ResultValue =Asc(Mid(Table, TableIndex, 1)) Mod MidWordValue Result = Result +Hex(ResultValue) Next I SourceString = Result Next t Dim BitTORool AsInteger For t =1ToLen(CStr(SRC)) BitTORool = SRC And2^ t For I =1To BitTORool SourceString =Right(SourceString, 1) _ +Left(SourceString, Len(SourceString) -1) Next I Next t If PASSWORD = GETSERIALPASSWORD Then getSerial = SourceString Else getSerial ="你无权获得软件序列号" EndIf End Function '验证序列号是否正确 PublicFunction IsSerial(ByVal Serial AsString) AsBoolean If Serial = getSerial(GetApplySerial(), GETSERIALPASSWORD) Then IsSerial =True Else IsSerial =False EndIf End Function PublicFunction checkSerial() Dim II AsNew INI II.FileName ="D:akJFManageserial.ini"'INI文件名 II.AppName ="SERIAL"'INI小节名称 II.KeyName ="Serial"'INI项目名 Serial = II.GetINI If IsSerial(Serial) Then checkSerial ="通过注册码检查" Else checkSerial ="没通过注册码检查,请在serial.ini文件中设置注册码" II.KeyName ="ApplySerial"'INI项目名 II.ValueStr = GetApplySerial() II.WriteINI EndIf Set II =Nothing End Function
原作者:heraldboy
posted on
2004-12-04 20:08木木凡
阅读(401)
评论(0)
编辑收藏举报