encypemodule.bas

来自「VB 编写的"华成POS管理系统",代码全,没有进行测试,数据库全,有兴趣的朋友」· BAS 代码 · 共 75 行

Attribute VB_Name = "EncypeModule"
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

Public Function IsValidate(ByVal SRC As Long, ByVal Value As String) As Boolean
Dim SourceString As String
Dim NewSRC As Long

'--- Corver it to String ----
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
Dim TableIndex As Integer

'================================================================================
'这是密码表，根据你的要求换成别的，不过长度要一致
'================================================================================
'注意：这里的密码表变动后，对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
Table = "JSDJFKLUWRUOISDH;KSADJKLWQ;ABCDEFHIHL;KLADSHKJAGFWIHERQOWRLQH"
'================================================================================

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
'---- Let's rool the SourceString ----
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 SourceString = Value Then IsValidate = True

End Function
Public Function DriveSerial(ByVal sDrv As String) As Long
'Usage:
'Dim ds As Long
'ds = DriveSerial("C")
     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
     GetVolumeInformation sDrv & ":\", str, MAX_FILENAME_LEN, RetVal, _
                          a, b, str2, MAX_FILENAME_LEN
     DriveSerial = RetVal
End Function