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