自定义VB程序加密方案
目录
第一步，获取电脑标志
每一台电脑的标志有哪些？
1、硬盘***
2、电脑名
3、IP地址
想到的就这些了，本案列以C盘***和电脑名为电脑的识别依据，以阐述加密算法
获取C盘***代码：
Dim DriveID
Set DriveID = CreateObject("Scripting.FileSystemObject")
mySerial = DriveID.GetDrive("C").SerialNumber
获取电脑名代码：
dim PcName as string '电脑名
Set a = CreateObject("Wscript.Network")
PcName = a.ComputerName
OK，如果要给另一台电脑使用权限，限定识别时间，使用期限，加上试用次数
差不多了。比如：
信息大概这样写：2018/9/6_10_-2070513827_DESKTOP-NS7FOVN_2019/3/9
解释下：日期(后续程序可以自定义保留5天)_试用次数_未注册或者注册信息错误但格式正确，提取该数字每次打开“-1”， _C盘***_电脑名_到期日期(可设定为固定字段，然后封装到程序内，即便含义依然很难**算法【dll封】)
第二步，编密文
第一步的注册信息基本完备，如上图，如果就这样给用户使用程序，***随便编一个也可，辛苦敲定的程序就成了做贡献了，别吃饭了，但是我们如何让用户看不懂***呢——加密算法。看看别个的算法介绍：
https://blog.****.net/ddffr/article/details/77153127
看了算法原理介绍以后（其实想多了），个人这几个渣渣小程序还没那么大的影响力，稍微秀一下小算法，简单点你**依然很困难，除非你知道我的dll里面写的什么。来吧，我也来介绍下我的算法思路，算法相同，随便改改参数你都很难**，而且为了这点成本花这么大力气**这么简单的算法是没有必要的，我想。
2018/9/6_10_-2070513827_DESKTOP-NS7FOVN_2019/3/9，将每一个字符转化为2个字符
假定字符x,char(97)=a , ASC(a)=97 , 则ASC(x)=yy 或则 ASC(x)=zzz
大家知道，ascii码集中在33-126间，那么我减去某个数或则加上某个数那么这群数字就全是yy，或者zzz了
我在逆向算法时按字段长度取出来就是了，正向算法时不足加上某个特定字符就可以了
以下就是编译之后的***了，大哥们，谁有兴趣为小程序破译这个算法
1、注册有时限
2、试用有次数限制
3、指定使用阶段，本参数在dll里面，怎么破
4、限定使用时间
5、针对你的C盘***和电脑名仅此一份
本程序针对封闭式工程研发小程序，基本不予外网连接，困难点就是输入***较多，比较麻烦，但是实现原理简单
不想麻烦那就用参考链接里面的大数因式分解吧，以后研究，我还没考虑好该如何将这几个信息变成大数呢，各位欢迎评论
第三步，封装Dll
继承第二部，我们需要将理论的算法付诸实践
在该类模块插入以下代码，Change1是类Certif20的一个方法（正向编译成数字），其余程序就可以引用了——封装为dll。
Public Function Change1(ByVal Str1 As String) As String
Dim Str_B As String
For i = 1 To Len(Str1)
tt = Mid(Str1, i, 1)
Str_B = Str_B & (Asc(tt) - 30)
Next
Change1 = Str_B
End Function
逆向编译段
Public Function Change2(ByVal Str1 As String) As String
Dim State01 As Boolean
State01 = False
For i = 1 To Len(Str1) / 2
tt = Mid(Str1, i * 2 - 1, 2)
Str_C = Str_C & Chr(CInt(tt) + 30)
Next
Change2 = Str_C
End Function
以上代码是两位的，如果要弄成3位的也可，参数做一下修改
最后生成dll即可。
第四步，编客户端和***
图一图二分别是客户端和***界面，原理大家一看便知，便不多说了，直接上代码
注册
Private Sub Command1_Click()
Rem 获取C盘***
Dim C_str, CName, Str1 As String
Dim DriveID
Set DriveID = CreateObject("Scripting.FileSystemObject")
C_str = DriveID.GetDrive("C").SerialNumber
Set a = CreateObject("Wscript.Network")
CName = a.ComputerName
Dim Cer1 As Certif20
Set Cer1 = New Certif20
Str1 = Cer1.Change2(Text3.Text)
Dim Arr1
Arr1 = Split(Str1, "CQVB")
If UBound(Arr1) <> 2 Then
MsgBox "注册信息有误" & Chr(10) & "联系邮箱：[email protected]", , "注册失败"
Exit Sub
End If
If Arr1(1) <> CStr(C_str) Then
MsgBox "***不匹配" & Chr(10) & "联系邮箱：[email protected]", , "注册失败"
ElseIf InStr(Arr1(2), CName) <> 1 Then
MsgBox "电脑名不匹配" & Chr(10) & "联系邮箱：[email protected]", , "注册失败"
Else
Dim date2 As Date
date2 = right(Arr1(2), Len(Arr1(2)) - Len(CName))
MsgBox "恭喜恭喜！" & Chr(10) & "有效期至: " & date2, , "注册成功"
Rem 创建记录 *******************************************************
Rem 判断有无缓存记录（txt），无则创建一个空值
Dim fso As Object, blnExist As Boolean
Set fso = CreateObject("Scripting.FileSystemObject")
blnExist = fso.FileExists("D:\MSFus_1.0\Setting\Certif\licence.txt")
If blnExist = False Then
Dim sFile As Object
Set sFile = fso.CreateTextFile("D:\MSFus_1.0\Setting\Certif\licence.txt", True)
End If
Rem 读取TXT
Const ForWriting = 2
Set sFile = fso.OpenTextFile("D:\MSFus_1.0\Setting\Certif\licence.txt", 2, TristateFalse)
sFile.Write Text3.Text
sFile.Close
Set fso = Nothing
Set sFile = Nothing
End If
End Sub
C盘***
Private Sub Command2_Click()
Rem 获取C盘***
Dim DriveID
Set DriveID = CreateObject("Scripting.FileSystemObject")
Text1.Text = DriveID.GetDrive("C").SerialNumber
End Sub
电脑名
Private Sub Command3_Click()
Set a = CreateObject("Wscript.Network")
Text2.Text = a.ComputerName
End Sub
第五步，应用程序引用
按上面描述的，实现以下几个功能
1、注册有时限
2、试用有次数限制
3、指定使用阶段，本参数在dll里面
4、限定使用时间
5、针对你的C盘***和电脑名仅此一份
列：2018/9/6_10_-2070513827_DESKTOP-NS7FOVN_2019/3/9
1、逆向解析为上面信息串（使用dll的Change2）
2、获取生成***的日期，与当前日期比较10天内可以注册，其余时间不予注册
3、解析与本机不符的，但格式正确，将试用次数（-1），直至次数小于1程序提示不能使用，请注册
4、注册成功的，试用次数直接至零，判断使用末期与注册日期是否符合指定阶段，不是不给运行
5、判断当前日期是否比使用末期小，否则不予运行
OK了，代码后续跟上……感谢各位支持。
参考资源：