VB.NET项目软件一机一码加密授权实现方法

对软件进行一机一码加密，首先我们需要获取到硬件的相关信息，以下为代码：

 Friend Function 硬件ID(Optional 混淆字符串 = "这里写入任意个字符串") As String
        '推荐使用uuid 也可以换成其他组合
        Return "CJTEST-" & GetHash(混淆字符串 & GetUUID()) '这里自由选择组合 一般使用这2个或者单一个
    End Function
     Friend Function ListAllID() As String
        Dim wmiData As String() = {
            "系统盘硬盘信息==>" & 系统盘硬盘ID(),
            "MOTHERBOARD==>" & 主板信息(),
            "BIOS==>" & BIOS信息(),
            "GPU==>" & 显卡信息(),
            "CPU==>" & CPU信息(),
            "HDD==>" & 所有硬盘信息(),
            "网卡==>" & 网卡信息(),
            "UUID==>" & GetUUID()
        }
        Return String.Join(vbNewLine, wmiData)
    End Function
    Private Function 显卡信息() As String '显卡ID
        Return GetProperties({"Win32_VideoController", "Name", "DeviceID", "DriverVersion"})
    End Function

    Private Function GetUUID() As String '//系统唯一标识 正常重装后不变 wmic csproduct get uuid
        Dim searcher As New ManagementObjectSearcher("root\CIMV2", "SELECT * FROM Win32_ComputerSystemProduct")
        Dim rs As String = ""
        For Each queryObj As ManagementObject In searcher.Get()
            rs = queryObj("UUID").ToString
            Exit For
        Next
        If rs = "FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" Then
            rs = 系统盘硬盘ID()
        End If
        Return rs
    End Function

    Private Function 主板信息() As String '主板ID
        Return GetProperties({"Win32_BaseBoard", "Name", "Manufacturer", "SerialNumber"})
    End Function

    Private Function CPU信息() As String 'CPUID 系统重装会变
        Return GetProperties({"Win32_Processor", "Name", "Manufacturer", "ProcessorId"})
    End Function

    Private Function 所有硬盘信息() As String '//所有硬盘 一般不用它 可能包含移动硬盘
        Return GetProperties({"Win32_DiskDrive", "Model", "SerialNumber"})
    End Function

    Private Function BIOS信息() As String '//BIOS有些没有
        Return GetProperties({"Win32_BIOS", "Name", "Manufacturer", "SerialNumber"})
    End Function

    '//返回第一个网卡名称+地址 注意网卡地址是可以第三方软件修改的 一般不单独使用
    Private Function 网卡信息() As String
        Try
            Dim MoAddress As String = ""
            Using mc As ManagementClass = New ManagementClass("Win32_NetworkAdapterConfiguration")
                Dim moc2 As ManagementObjectCollection = mc.GetInstances()
                For Each mo As ManagementObject In moc2
                    If CBool(mo("IPEnabled")) = True Then
                        MoAddress = mo("Description").ToString() '描述信息
                        MoAddress = MoAddress & "," & mo("MacAddress").ToString()
                        Return MoAddress
                    End If
                    mo.Dispose()
                Next
            End Using
            Return MoAddress
        Catch ex As Exception
            Return ""
        End Try
    End Function

    Public Function 系统盘硬盘ID() As String
        Dim properties As New StringBuilder()
        Try
            Dim searcher As ManagementObjectSearcher = New ManagementObjectSearcher("SELECT DiskIndex FROM Win32_DiskPartition WHERE Bootable = TRUE")
            For Each mooo As ManagementObject In searcher.[Get]()
                Dim index As Integer = Convert.ToInt32(mooo.Properties("DiskIndex").Value)
                Dim searcher_model As ManagementObjectSearcher = New ManagementObjectSearcher("SELECT Model,SerialNumber FROM Win32_DiskDrive WHERE Index = " & index)
                Dim moc1 As ManagementObjectCollection = searcher_model.[Get]()
                For Each mo As ManagementObject In moc1
                    properties.Append(CStr(mo.Properties("Model").Value))
                    properties.Append(",")
                    properties.Append(CStr(mo.Properties("SerialNumber").Value))
                Next
            Next
            Return Mid(properties.ToString(), 2)
        Catch ex As Exception
            Return ""
        End Try
    End Function

然后设计一个窗体

Friend Sub 验证本机激活码()
        '启动时读取注册表 或者配置文件 这里演示为读取注册表
        Dim 机器码 = New C硬件ID().硬件ID() '获取机器码 

        Dim 激活码 = 注册表激活码.记录值
        If 激活码 = "" Then
            '首次运行注册表为空 则写入一个免费版注册表
            Dim 到期日期
            到期日期 = Now.AddDays(7) '设定用户机器首次安装后7天
            激活码 = String.Format("{0};{1};{2}", 机器码, "免费版", 到期日期) '用分号分隔多组信息
            '激活码 = String.Format("{0};{1};{2}", 机器码, "免费版", CDate("2999-1-1")) '用分号分隔
            注册表激活码.记录值 = mBase64.字符串编码(激活码)

        End If
        'If 首次安装时间.记录值 = "" Then
        '    首次安装时间.记录值 = mBase64.字符串编码(Now.ToString("yyyy-MM-dd")) '首次安装的时候 注册表记录安装时间
        'End If
        验证激活码(激活码, 机器码)

    End Sub

    Friend Sub 验证本机激活码(激活码) '用于测试 客户端可注释掉
        Dim 机器码 = New C硬件ID().硬件ID() '获取机器码 
        验证激活码(激活码, 机器码)
    End Sub

    Friend Sub 验证激活码(激活码 As String, 机器码 As String)
        验证结果 = New C验证结果(激活码, 机器码)
    End Sub
    Friend Function 解析激活码(激活码 As String)
        '这里也可以自己换成其他方式
        Return mBase64.字符串解码(激活码)
    End Function
    Friend Sub 显示激活窗口()
        Dim frm = New Frm注册()
        frm.ShowDialog()
    End Sub
    <Obfuscation(Feature:="virtualization", Exclude:=False)>
    <Obfuscation(Feature:="inline", Exclude:=False)>'内联编译 编译后直接作为一整个函数 无法按功能区分 加大破解难度
    Friend Class C验证结果 '/根据自己的权限划分在这里规划验证类
        Friend 激活码解析成功 As Boolean = False
        Friend 解析机器码 As String = ""
        Friend 授权版本 As String = "免费版" '默认为免费版
        Friend 到期日期 As Date = CDate("1990-1-1") '预设一个很早的时间
        Private 机器码 As String
        Sub New()

        End Sub
        Sub New(激活信息, _机器码)
            Try

                Dim arr = Split(激活信息, ";") '3组信息 用分号分隔
                解析机器码 = arr(0)
                机器码 = _机器码
                If 机器码 <> 解析机器码 Then
                    '机器码不符合 退出验证 只能作为免费版
                    授权版本 = "免费版"
                    到期日期 = Now.AddDays(7)
                    激活码解析成功 = False
                    Return
                End If
                授权版本 = arr(1)
                到期日期 = arr(2)
                激活码解析成功 = True
                注册表激活码.记录值 = 激活信息 '更新注册表激活码
            Catch ex As Exception
                激活码解析成功 = False
                注册表激活码.记录值 = ""  '更新注册表激活码
            End Try


        End Sub

        Function 是否到期() '22.02.24
            If 当前日期() > 到期日期 Then '再检查过期时间
                Return True '已过期
            Else
                Return False '还没到期
            End If
        End Function
        Function 显示结果() As String
            Dim 解析成功 = "解析失败"
            If 激活码解析成功 Then
                解析成功 = "解析成功"
            End If
            Return $"{解析成功}!授权为:{授权版本},到期时间为{到期日期.ToShortDateString}"
        End Function

    End Class
    Function VIP试用次数检验() As Boolean
        If 验证结果 Is Nothing Then
            验证本机激活码()
        End If
        If 验证结果.授权版本 = "免费版" Then
            '进入免费版次数检查
            If 检查免费版授权有效期() Then
                Dim v = Val(VIP功能试用次数.记录值)
                If v >= 2 Then
                    MsgBox("本VIP功能试用次数已超限!")
                    显示激活窗口()
                    Return False
                End If
                'VIP功能用一次 要+1
                VIP功能试用次数.记录值 = v + 1
            Else '免费版的有效期已过了 也要弹出注册对话框
                显示激活窗口()
                Return False
            End If
        Else 'VIP验证
            If Not m客户端验证授权.检查VIP版授权带弹框 Then
                显示激活窗口()
                Return False '如果VIP已到期 也退出 弹出注册对话框
            End If
        End If
        Return True
    End Function
    Friend Function 检查免费版授权() As Boolean
        '免费版功能无使用期限 
        If 验证结果.授权版本 = "免费" Then
            Return True
        End If
        Return False
    End Function
    Friend Function 检查免费版授权有效期() As Boolean
        '免费版功能无使用期限 
        If 验证结果 Is Nothing Then
            验证本机激活码()
        End If

        If 验证结果.授权版本 = "免费版" Then
            If 验证结果.是否到期 Then
                Return False '已失效
            Else
                Return True '有效
            End If
        Else 'VIP版本直接返回在有效期内
            Return True
        End If
        Return False
    End Function
    Friend Function 检查VIP版授权带弹框() As Boolean
        'VIP版需核对使用期限 方便发放VIP试用版
        If 验证结果 Is Nothing Then
            验证本机激活码()
        End If
        If 验证结果.授权版本 = "VIP" Then '检查授权版本
            If 验证结果.到期日期 >= 当前日期() Then '再检查过期时间
                Return True '都满足的时候才会继续往下执行
            Else
                MsgBox("VIP授权已过期,请重新激活!")
                Return False
            End If
        Else
            MsgBox("本功能需开通VIP才可使用!")
            Return False
        End If
        Return False
    End Function
    Friend Function 检查VIP版授权无弹框() As Boolean
        'VIP版需核对使用期限 方便发放VIP试用版
        If 验证结果 Is Nothing Then
            验证本机激活码()
        End If
        If 验证结果.授权版本 = "VIP" Then '检查授权版本

            If 验证结果.到期日期 >= 当前日期() Then '再检查过期时间
                Return True '都满足的时候才会继续往下执行
            Else
                Return False
            End If
        Else
            Return False
        End If
        Return False
    End Function
    Private Function 当前日期() As DateTime '通过读取临时文件最新日期得到当前日期 即使断网也能读到
        Dim tmppath As String = System.IO.Path.GetTempPath()
        'Dim tmpFilelist As String() = Directory.GetFiles(tmppath, "*", SearchOption.TopDirectoryOnly).ToArray()
        'Dim fs As FileInfo = Nothing
        Dim dt As DateTime = DateTime.MinValue
        Dim info As DirectoryInfo = New DirectoryInfo(tmppath)
        Dim newestFile As FileInfo = info.GetFiles().OrderBy(Function(n) n.CreationTime.Date).Last

        If DateTime.Compare(newestFile.CreationTime.Date, dt) > 0 Then dt = newestFile.CreationTime.Date

        If DateTime.Compare(DateTime.Today, dt) > 0 Then
            dt = DateTime.Today
        End If
        Return dt
    End Function
    ' 功能测试
    Sub VIP功能() 'VIP功能放入虚拟机
        If Not 检查VIP版授权带弹框() Then
            Return '授权检查不满足会直接返回
        End If

        MsgBox("尊贵的VIP,欢迎使用!")
    End Sub
    Friend Function MD5加密(ByVal 目标字符串 As String,
                           Optional ByVal 加混淆 As String = "880VSTO",'混淆字符自己修改
                           Optional ByVal bit As Integer = 16) As String
        Dim md5Hasher As MD5CryptoServiceProvider = New MD5CryptoServiceProvider()
        Dim hashedDataBytes As Byte()
        hashedDataBytes = md5Hasher.ComputeHash(Encoding.Default.GetBytes(目标字符串))
        Dim tmp As StringBuilder = New StringBuilder()

        For Each i As Byte In hashedDataBytes
            tmp.Append(i.ToString("x2"))
        Next

        If bit = 16 Then
            Return tmp.ToString().Substring(8, 16)
        ElseIf bit = 32 Then
            Return tmp.ToString()
        Else
            Return String.Empty
        End If
    End Function
End Module

最后是客户端授权验证：

 Friend Function 读取注册表(ByVal 子节点 As String) As String
        Dim RootKey, RegKey As Microsoft.Win32.RegistryKey
        RootKey = Microsoft.Win32.Registry.CurrentUser.OpenSubKey("Software", True)

        RegKey = RootKey.OpenSubKey(注册表目录, True)
        If RegKey Is Nothing Then
            RootKey.CreateSubKey(注册表目录) '不存在，则创建子项
            RegKey = RootKey.OpenSubKey(注册表目录, True)
        End If
        Dim value As String = ""
        Try
            value = RegKey.GetValue(子节点).ToString()
        Catch ex As Exception
            value = "null" '//读取不到则写入null值
            RegKey.SetValue(子节点, value.ToString, Microsoft.Win32.RegistryValueKind.String)
        End Try
        'Debug.Print(RegKey.Name)

        If value = "null" Then
            value = ""
        End If
        Return value
    End Function
    Friend Sub 写入注册表(ByVal 子节点 As String, ByVal value As String)
        Dim RootKey, RegKey As Microsoft.Win32.RegistryKey
        RootKey = Microsoft.Win32.Registry.CurrentUser.OpenSubKey("Software", True)
        RegKey = RootKey.OpenSubKey(注册表目录, True)
        If RegKey Is Nothing Then
            RootKey.CreateSubKey(注册表目录) '不存在，则创建子项
            RegKey = RootKey.OpenSubKey(注册表目录, True)
        End If
        RegKey.SetValue(子节点, value.ToString(), Microsoft.Win32.RegistryValueKind.String)
    End Sub