|
|
本帖最后由 yz0116 于 2023-4-3 08:12 编辑
我有一个execl表，我想让经过我授权的用户方能使用，想用VBA为该EXECL表添加授权码机制，同时用VBA编个注册机。
具体是用VBA写个代码，获取当前电脑硬盘C盘序列号并转成机器码，然后用sha-1计算哈希值法计算出授权码，在EXECL表打开时显示机器码，并要求填入授权码,当输入的授权码和计算的授权码一致时，EXECL表可以打开，否则自动关闭
用VBA写个注册机，当用户输入之前程序显示的机器码时，用同样的方法计算出授权码，并同时显示出机器码和授权码，其中授权码是可以复制的
我借用GPT写了一个代码，可老是运行出错，请哪位大神指点一下：
授权码机制：
Private Declare PtrSafe Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Sub Workbook_Open()
'获取C盘序列号并转成机器码
Dim machineCode As String
machineCode = GetVolumeSerialNumber("C:\")
'计算授权码
Dim authCode As String
authCode = SHA3(machineCode)
'显示机器码
MsgBox "请提供机器码：" & vbCrLf & machineCode
'要求填入授权码
Dim inputAuthCode As String
inputAuthCode = InputBox("请输入授权码：")
'验证授权码
If SHA3(inputAuthCode) <> authCode Then
MsgBox "授权码不正确，无法打开文件。"
ThisWorkbook.Close False
End If
End Sub
Function GetVolumeSerialNumber(ByVal strDriveLetter As String) As String
Dim lpVolumeSerialNumber As Long
Dim lpMaximumComponentLength As Long
Dim lpFileSystemFlags As Long
Dim lpFileSystemNameBuffer As String
Dim nFileSystemNameSize As Long
lpVolumeSerialNumber = 0
lpMaximumComponentLength = 0
lpFileSystemFlags = 0
lpFileSystemNameBuffer = String$(255, Chr$(0))
nFileSystemNameSize = Len(lpFileSystemNameBuffer)
Dim result As Long
result = GetVolumeInformation(strDriveLetter, vbNullString, 0, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize)
If result <> 0 Then
GetVolumeSerialNumber = Hex(lpVolumeSerialNumber)
End If
End Function
Function SHA3(ByVal str As String) As String
Dim shaObj As Object
Set shaObj = CreateObject("System.Security.Cryptography.SHA3Managed")
Dim bytes() As Byte
bytes = StrConv(str, vbFromUnicode)
Dim hash() As Byte
hash = shaObj.ComputeHash_2((bytes))
SHA3 = ByteArrayToString(hash)
End Function
Function ByteArrayToString(ByVal arr() As Byte) As String
Dim i As Long
For i = LBound(arr) To UBound(arr)
ByteArrayToString = ByteArrayToString & Right("0" & Hex(arr(i)), 2)
Next i
End Function
注册机：
Private Sub btnCalc_Click()
Dim machineCode As String
'获取输入框中的机器码
machineCode = txtMachineCode.Value
'计算授权码
Dim authCode As String
authCode = SHA3(machineCode)
'显示机器码和授权码
txtAuthCode.Value = authCode
txtMachineCode.SetFocus
txtMachineCode.SelStart = 0
txtMachineCode.SelLength = Len(txtMachineCode.Value)
End Sub
Private Sub btnCopy_Click()
'复制授权码到剪贴板
Clipboard.SetText txtAuthCode.Value
End Sub
Function SHA3(ByVal str As String) As String
Dim shaObj As Object
Set shaObj = CreateObject("System.Security.Cryptography.SHA3Managed")
Dim bytes() As Byte
bytes = StrConv(str, vbFromUnicode)
Dim hash() As Byte
hash = shaObj.ComputeHash_2((bytes))
SHA3 = ByteArrayToString(hash)
End Function
Function ByteArrayToString(ByVal arr() As Byte) As String
Dim i As Long
For i = LBound(arr) To UBound(arr)
ByteArrayToString = ByteArrayToString & Right("0" & Hex(arr(i)), 2)
Next i
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-31 15:01
楼主
