ASP编程获得硬盘序列号

 

Private  Declare  Function  GetVolumeInformation &  Lib  " kernel32 "  Alias  " GetVolumeInformationA "  (ByVal lpRootPathName  As   String , ByVal pVolumeNameBuffer  As   String , ByVal nVolumeNameSize  As   Long , lpVolumeSerialNumber  As   Long , lpMaximumComponentLength  As   Long , lpFileSystemFlags  As   Long , ByVal lpFileSystemNameBuffer  As   String , ByVal nFileSystemNameSize  As   Long )
Private   Const  MAX_FILENAME_LEN  =   256
Private   Const  GETSERIALPASSWORD  =   " lxy "
Public   Function  DriveSerial(ByVal sDrv  As   String )  As   Long     ' 得到硬盘的序列号
     Dim  RetVal  As   Long
     Dim  str  As   String   *  MAX_FILENAME_LEN
     Dim  str2  As   String   *  MAX_FILENAME_LEN
     Dim  a  As   Long
     Dim  b  As   Long

     Call  GetVolumeInformation(sDrv  &   " : " , str, MAX_FILENAME_LEN, RetVal, a, b, str2, MAX_FILENAME_LEN)
    DriveSerial  =  RetVal
    
End Function
Public   Function  GetApplySerial()  As   Long      ' 根据c盘的序列号生成一个申请码
    GetApplySerial  =  DriveSerial( " c " )
     If  GetApplySerial  <   0   Then  GetApplySerial  =   0   -  GetApplySerial
End Function
' 根据申请码和密码表及密码得到序列号
Public   Function  getSerial(ByVal SRC  As   Long , ByVal PASSWORD  As   String )  As   String

     Dim  SourceString  As   String
     Dim  NewSRC  As   Long

     For  I  =   0   To   30
         If  (SRC  And   2   ^  I)  =   2   ^  I  Then
            SourceString  =  SourceString  +   " 1 "
         Else
            SourceString  =  SourceString  +   " 0 "
         End   If
     Next  I
     If  SRC  <   0   Then
        SourceString  =  SourceString  +   " 1 "
     Else
        SourceString  =  SourceString  +   " 0 "
     End   If
    
    
     Dim  Table  As   String
     ' ==========================================================================
     ' 参数Table是密码表，根据你的要求换成别的，不过长度要一致
     ' ==========================================================================
     ' 注意：这里的密码表变动后，对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
    Table  =   " JSDJFKLUWRUOISDH;KSADJKLWQ;ABCDEFHIHL;KLADSDKJAGFWIHERQOWRLQH "
     ' ==========================================================================
    
    
     Dim  TableIndex  As   Integer
     Dim  Result  As   String
     Dim  MidWord  As   String
     Dim  MidWordValue  As   Byte
     Dim  ResultValue  As   Byte

     For  t  =   1   To   1
         For  I  =   1   To   Len (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  As   Integer

     For  t  =   1   To   Len ( CStr (SRC))
        BitTORool  =  SRC  And   2   ^  t
         For  I  =   1   To  BitTORool
            SourceString  =   Right (SourceString,  1 ) _
             +   Left (SourceString,  Len (SourceString)  -   1 )
         Next  I
     Next  t
     If  PASSWORD  =  GETSERIALPASSWORD  Then
        getSerial  =  SourceString
     Else
        getSerial  =   " 你无权获得软件序列号 "
     End   If
End Function
' 验证序列号是否正确
Public   Function  IsSerial(ByVal Serial  As   String )  As   Boolean
     If  Serial  =  getSerial(GetApplySerial(), GETSERIALPASSWORD)  Then
        IsSerial  =   True
     Else
        IsSerial  =   False
     End   If
End Function
Public   Function  checkSerial()
     Dim  II  As   New  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
     End   If
     Set  II  =   Nothing
End Function

原作者：heraldboy