cách tạo bản quyền cho file excel bằng Regedit (7 người xem)

[Minh Tam 2024]

Code nguồn trên mạng . Mọi người xem có khả thi không

Function CheckRegistry(ByVal Paths$, ByVal Entry$) As Boolean
'Haøm kieåm tra Registry coù toàn taïi
'[Paths]: Thö muïc chöùa - [Entry]: Teân thuoäc tính
Dim Obj, Fullpaths$
On Error Resume Next
Fullpaths = "HKCC\ABCExcel\" & Paths & "\" & Entry
Set Obj = CreateObject("WScript.Shell")
Entry = Obj.RegRead(Fullpaths)
    If err.Number <> 0 Then
        err.Clear
        CheckRegistry = False
    Else
        err.Clear
        CheckRegistry = True
  End If
End Function

Function GetRegistry(ByVal Paths$, ByVal Entry$)
'Haøm laáy giaù trò Registry
'[Paths]: Thö muïc chöùa - [Entry]: Teân thuoäc tính
Dim Obj, Fullpaths$
On Error Resume Next
Fullpaths = "HKCC\ABCExcel\" & Paths & "\" & Entry
    Set Obj = CreateObject("WScript.Shell")
    GetRegistry = Obj.RegRead(Fullpaths)
End Function

Public Sub WriteRegistry(ByVal Paths$, ByVal Entry$, ByVal values$)
'Taïo môùi hoaëc tuøy chænh giaù trò Registry
'[Paths]: Thö muïc chöùa - [Entry]: Teân thuoäc tính
Dim Obj, Fullpaths$
On Error Resume Next
Fullpaths = "HKCC\ABCExcel\" & Paths & "\" & Entry
    Set Obj = CreateObject("WScript.Shell")
    Obj.RegWrite Fullpaths, values, "REG_SZ"
End Sub

Private Function Encod(ByVal txt$) As Long
'Thuaät toaùn maõ hoùa
    Dim xVal As Long
    Dim xCh As Long
    Dim xSft1 As Long
    Dim xSft2 As Long
    Dim i%
    Dim xLen%
    xLen = Len(txt)
    For i = 1 To xLen
        xCh = Asc(Mid$(txt, i, 1))
        xVal = xVal Xor (xCh * 2 ^ xSft1)
        xVal = xVal Xor (xCh * 2 ^ xSft2)
        xSft1 = (xSft1 + 7) Mod 19
        xSft2 = (xSft2 + 13) Mod 23
    Next i
    Encod = xVal
End Function

Function OpenKey(ByVal Psd$, ByVal InTxt$, Optional ByVal Enc As Boolean = True) As String
'Haøm maõ hoùa license
Dim xOffset!, xLen%, i%, xCh%, xOutTxt$
    xOffset = Encod(ReverseText(Psd) & "TafExcel")
    Rnd -1
    Randomize xOffset
    xLen = Len(InTxt)
    For i = 1 To xLen
        xCh = Asc(Mid$(InTxt, i, 1))
        If xCh >= 32 And xCh <= 126 Then
            xCh = xCh - 32
            xOffset = Int((96) * Rnd)
            If Enc Then
                xCh = ((xCh + xOffset) Mod 95)
            Else
                xCh = ((xCh - xOffset) Mod 95)
                If xCh < 0 Then xCh = xCh + 95
            End If
            xCh = xCh + 32
            xOutTxt = xOutTxt & Chr$(xCh)
        End If
    Next i
    OpenKey = xOutTxt
End Function

Function HDSerialNumber() As String
'Hieån thò serial number cuûa HDD
Dim oFSO As Object
Dim drive As Object
Dim Serial As String, MyPath

    If Application.ActiveWorkbook Is Nothing Then
        Application.Workbooks.Add
    End If
        
    MyPath = Environ("SystemDrive") & Application.PathSeparator
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set drive = oFSO.GetDrive("" & MyPath & "")
    'Maõ hoùa serial number cua HDD
    HDSerialNumber = Hex(drive.SerialNumber)
End Function

Function ProcessorInfo()
'Hieån thò thoâng tin CPU
Dim cimv2, PInfo, PItem
Dim PubStrComputer As String
    PubStrComputer = "."
    Set cimv2 = GetObject("winmgmts:\\" & PubStrComputer & "\root\cimv2")
    Set PInfo = cimv2.ExecQuery("Select * From Win32_Processor")
    For Each PItem In PInfo
        'MsgBox ("Processor: " & PItem.Name & vbCrLf & "Id: " & PItem.ProcessorId)
        ProcessorInfo = PItem.ProcessorId
    Next PItem
End Function

Function Limit(ByVal Paths$, ByVal Entry$, Optional ByVal n, Optional ByVal Limitation) As Boolean
'Giôùi haïn döõ lieäu keát hôïp kieåm tra license
'Löu yù khoâng taïo kieåu bieán cho n vaø limitation
Dim UserKey$
    UserKey = GetRegistry(Paths, Entry)

'B1. Kieåm tra license
    If OpenKey(Entry, HDSerialNumber, True) = UserKey Then
        Limit = True
        Exit Function
    End If
    
 'B2. Duøng thöû neáu coù
    If Not IsMissing(n) Or Not IsMissing(Limitation) Then
        If n > Limitation Then Limit = False Else Limit = True
    End If
End Function

Sub DisableLicense()
'Huûy baûn quyeàn test phaàn meàm
    Call WriteRegistry("System", "Addins", 0)
End Sub

 

[tambv2012]

Bạn có thể giải thích chi tiết hơn đc hiong, bạn ơi?