文本文件的基本加密
Basic encrypting of a text file
我正在尝试加密文件。我不需要花哨的加密，只需要让视线远离它。我在网上找到了一个名为 szEncryptDecrypt (https://www.devx.com/tips/Tip/5676) 的函数，它非常适合我的需要，因为它使用简单，并且隐藏了数据。但是，从文件中读取时我似乎无法让它工作。在宏中将一个字符串传递给它并再次解密它工作正常，但写入文件然后读取它不起作用。
我有一个写子、一个读子和一个加密子。如果使用非加密数据，读写子似乎可以正常工作（除非它也得到隐藏字符）。
我在解密之前尝试了对字符串的 trim 函数，但是没有用。
Option Compare Database
Sub WriteSettingsFile()
Dim db As DAO.Database
Dim fld As DAO.Field
Set db = CurrentDb
'Open Setings File name
Dim filePath As String
Dim TextFile As Integer
TextFile = FreeFile
filePath = Application.CurrentProject.Path & "\settings.cfg"
Open filePath For Output As TextFile
Print #TextFile, szEncryptDecrypt("Hello World")
Close TextFile
End Sub
Sub ReadSettingsFile()
Dim strFilename As String
strFilename = Application.CurrentProject.Path & "\settings.cfg"
Dim strTextLine As String
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
Do Until EOF(1)
Line Input #1, strTextLine
MsgBox strTextLine 'Not Encrypted
MsgBox szEncryptDecrypt(strTextLine) 'Encrypted
Loop
Close #iFile
End Sub
Function szEncryptDecrypt(ByVal szData As String) As String
' This key value can be changed to alter the encryption,
' but it must be the same for both encryption and decryption.
Const KEY_TEXT As String = "asdfghjkl"
' The KEY_OFFSET is optional, and may be any value 0-64.
' Likewise, it needs to be the same coming/going.
Const KEY_OFFSET As Long = 0
Dim bytKey() As Byte
Dim bytData() As Byte
Dim lNum As Long
Dim szKey As String
For lNum = 1 To ((Len(szData) \ Len(KEY_TEXT)) + 1)
szKey = szKey & KEY_TEXT
Next lNum
bytKey = Left$(szKey, Len(szData))
bytData = szData
For lNum = LBound(bytData) To UBound(bytData)
If lNum Mod 2 Then
bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) + KEY_OFFSET)
Else
bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) - KEY_OFFSET)
End If
Next lNum
szEncryptDecrypt = bytData
End Function
Sub TestEncrypt()
'This sub works fine
Dim str As String
str = szEncryptDecrypt("Hello World!")
MsgBox "Encrypted" & vbNewLine & str
MsgBox "Decrypted" & vbNewLine & szEncryptDecrypt(str)
End Sub
有没有更好的文本文件加密功能？
是啊，你发现的那个加密函数很简单，但是很差。它使用偏移量进行简单的异或运算。这意味着如果有人可以让你加密一个已知的字符串并且可以读取输出，他们就可以计算出密钥。此外，没有链接，所以我们没有 diffusion，文本中重复的模式将导致相同的输出，因此可以推断出常见的模式。
我自己研究了一种复杂的加密方法，在 CBC 模式下使用 AES-128。但是，所需的代码相当长。它使用 CNG API 进行加密。其他人使用 .Net，后者又使用 CNG，但会导致代码更短。我不想这样做，因为它依赖于 COM 对象并且可以覆盖这些对象。
让我们从用法开始吧：很简单。使用 EncryptString(StringToEncrypt, Key) 加密字符串，然后使用 DecryptString(StringToDecrypt, Key) 再次解密。它使用 Base64 编码来表示加密的字符串，因此输出应该可以安全地存储在只接受有效 unicode 字符串的字段中（也与您找到的实现相反）。
然后是基础知识。 CBC 模式下的 AES-128 是一种块密码，因此它需要一个固定长度的密钥，并且还以 128 位的完整块进行加密。为了解决这个问题，我们使用 SHA1 将密钥减少到固定长度，并将输入数据的长度存储在加密字符串中以忽略任何填充（末尾的附加字符）。
然后，在CBC模式下，它还需要一个初始化向量（IV）。我们随机生成那个，并将它不加密地存储（因为我们需要它来解密）在字符串的末尾。由于我们随机生成 IV，用相同的密钥对相同的字符串加密两次将导致完全不同的加密字符串，这通常是可取的（如果你加密密码，你不希望有人能够检查谁都拥有和你一样的密码）。
此代码还对数据进行哈希处理，并将加密后的哈希值与数据一起存储。这意味着它可以轻松检查您的密钥是否有效，如果无效，它不会 return 任何东西。
生成的代码相当冗长。可以通过不在 VBA 中进行 Base64 编码、不使用密码安全的随机数生成器或对所有内容使用 .Net 来减少它，但这不是我想要的。我建议将其粘贴到单独的模块中。
Option Compare Binary
Option Explicit
Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Public Declare PtrSafe Function BCryptSetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbInput As Any, ByVal cbInput As Long, ByVal dfFlags As Long) As Long
Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Public Declare PtrSafe Function BCryptGenRandom Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, pbBuffer As Any, ByVal cbBuffer As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef hKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptEncrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDecrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyKey Lib "BCrypt.dll" (ByVal hKey As LongPtr) As Long
Public Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32.dll" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Const BCRYPT_BLOCK_PADDING As Long = &H1
Public Type QuadSextet
s1 As Byte
s2 As Byte
s3 As Byte
s4 As Byte
End Type
Public Function ToBase64(b() As Byte) As String
Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim l As Long
Dim output As String
Dim UBoundOut As Long
UBoundOut = UBound(b) + 1
If UBoundOut Mod 3 <> 0 Then
UBoundOut = UBoundOut + (3 - UBoundOut Mod 3)
End If
UBoundOut = (UBoundOut \ 3) * 4
output = String(UBoundOut, vbNullChar)
Dim qs As QuadSextet
For l = 0 To (UBound(b) - 2) \ 3
qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1), b(l * 3 + 2))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1)
Mid(output, (l * 4) + 4, 1) = Mid(Base64Table, qs.s4 + 1, 1)
Next
If UBound(b) + 1 - (l * 3) = 2 Then
qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1)
Mid(output, (l * 4) + 4, 1) = "="
ElseIf UBound(b) + 1 - (l * 3) = 1 Then
qs = BytesToQuadSextet(b(l * 3))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 2) = "=="
End If
ToBase64 = output
End Function
Public Function Base64ToBytes(strBase64 As String) As Byte()
Dim outBytes() As Byte
Dim lenBytes As Long
lenBytes = Len(strBase64) * 3 \ 4
If Right(strBase64, 1) = "=" Then lenBytes = lenBytes - 1
If Right(strBase64, 2) = "==" Then lenBytes = lenBytes - 1
ReDim outBytes(0 To lenBytes - 1)
Dim l As Long
Dim qs As QuadSextet
For l = 0 To lenBytes - 1
Select Case l Mod 3
Case 0
qs = Base64ToQuadSextet(Mid(strBase64, (l \ 3) * 4 + 1, 4))
outBytes(l) = qs.s1 * 2 ^ 2 + (qs.s2 \ 2 ^ 4)
Case 1
outBytes(l) = (qs.s2 * 2 ^ 4 And 255) + qs.s3 \ 2 ^ 2
Case 2
outBytes(l) = (qs.s3 * 2 ^ 6 And 255) + qs.s4
End Select
Next
Base64ToBytes = outBytes
End Function
Public Function BytesToQuadSextet(b1 As Byte, Optional b2 As Byte, Optional b3 As Byte) As QuadSextet
BytesToQuadSextet.s1 = b1 \ 4
BytesToQuadSextet.s2 = (((b1 * 2 ^ 6) And 255) \ 4) + b2 \ (2 ^ 4)
BytesToQuadSextet.s3 = (((b2 * 2 ^ 4) And 255) \ 4) + b3 \ (2 ^ 6)
BytesToQuadSextet.s4 = (((b3 * 2 ^ 2) And 255) \ 4)
End Function
Public Function Base64ToQuadSextet(strBase64 As String) As QuadSextet
Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Base64ToQuadSextet.s1 = InStr(Base64Table, Mid(strBase64, 1, 1)) - 1
Base64ToQuadSextet.s2 = InStr(Base64Table, Mid(strBase64, 2, 1)) - 1
Base64ToQuadSextet.s3 = InStr(Base64Table, Mid(strBase64, 3, 1)) - 1
Base64ToQuadSextet.s4 = InStr(Base64Table, Mid(strBase64, 4, 1)) - 1
End Function
Public Function StringToBase64(str As String) As String
StringToBase64 = ToBase64(StrConv(str, vbFromUnicode))
End Function
Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA1") As Byte()
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
End Function
Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
'Erik A, 2019
'Hash data by using the Next Generation Cryptography API
'Loosely based on https://docs.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
'Allowed algorithms: https://docs.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support
'Error handling not implemented!
On Error GoTo VBErrHandler
Dim errorMessage As String
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = HashingAlgorithm & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler
'Determine hash object size, allocate memory
Dim bHashObject() As Byte
Dim cmd As String
cmd = "ObjectLength" & vbNullString
Dim Length As Long
If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bHashObject(0 To Length - 1)
'Determine digest size, allocate memory
Dim hashLength As Long
cmd = "HashDigestLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bHash() As Byte
ReDim bHash(0 To hashLength - 1)
'Create hash object
Dim hHash As LongPtr
If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
'Hash data
If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
'Return result
NGHash = bHash
ExitHandler:
'Cleanup
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
If hHash <> 0 Then BCryptDestroyHash hHash
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Sub NGRandom(pData As LongPtr, lenData As Long, Optional Algorithm As String = "RNG")
'Erik A, 2019
'Fills data at pointer with random bytes
'Error handling not implemented!
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = Algorithm & vbNullChar
BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0
'Fill bytearray with random data
BCryptGenRandom hAlg, ByVal pData, lenData, 0
'Cleanup
BCryptCloseAlgorithmProvider hAlg, 0
End Sub
Public Sub NGRandomW(Data() As Byte, Optional Algorithm As String = "RNG")
If LBound(Data) = -1 Then Exit Sub
NGRandom VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, Algorithm
End Sub
Public Function NGEncrypt(pData As LongPtr, lenData As Long, inpIV As LongPtr, inpIVLength As Long, inpSecret As LongPtr, inpSecretLength As Long) As Byte()
'Encrypt pData using AES encryption, inpIV and inpSecret
'Input: pData -> mempointer to data. lenData: amount of bytes to encrypt. inpIV: mempointer to IV. inpSecret: mempointer to 128-bits secret.
'Output: Bytearray containing encrypted data
Dim errorMessage As String
On Error GoTo VBErrHandler
Dim hAlg As LongPtr
Dim algId As String
'Open algorithm provider
algId = "AES" & vbNullChar
BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0
'Allocate memory to hold the KeyObject
Dim cmd As String
Dim keyObjectLength As Long
cmd = "ObjectLength" & vbNullString
BCryptGetProperty hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0
Dim bKeyObject() As Byte
ReDim bKeyObject(0 To keyObjectLength - 1)
'Check block length = 128 bits, copy IV
Dim ivLength As Long
Dim bIV() As Byte
cmd = "BlockLength" & vbNullChar
BCryptGetProperty hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0
If ivLength > inpIVLength Then
Debug.Print
End If
ReDim bIV(0 To ivLength - 1)
RtlMoveMemory bIV(0), ByVal inpIV, ivLength
'Set chaining mode
cmd = "ChainingMode" & vbNullString
Dim val As String
val = "ChainingModeCBC" & vbNullString
BCryptSetProperty hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0
'Create KeyObject using secret
Dim hKey As LongPtr
BCryptGenerateSymmetricKey hAlg, hKey, bKeyObject(0), keyObjectLength, ByVal inpSecret, inpSecretLength, 0
'Calculate output buffer size, allocate output buffer
Dim cipherTextLength As Long
BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, cipherTextLength, BCRYPT_BLOCK_PADDING
Dim bCipherText() As Byte
ReDim bCipherText(0 To cipherTextLength - 1)
'Encrypt the data
Dim dataLength As Long
BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bCipherText(0), cipherTextLength, dataLength, BCRYPT_BLOCK_PADDING
'Output the encrypted data
NGEncrypt = bCipherText
ExitHandler:
'Destroy the key
If hKey <> 0 Then BCryptDestroyKey hKey
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Function NGEncryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
NGEncryptW = NGEncrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
End Function
Public Function NGDecrypt(pData As LongPtr, lenData As Long, pIV As LongPtr, lenIV As Long, pSecret As LongPtr, lenSecret As Long) As Byte()
Dim errorMessage As String
On Error GoTo VBErrHandler
Dim hAlg As LongPtr
Dim algId As String
'Open algorithm provider
algId = "AES" & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) <> 0 Then GoTo ErrHandler
'Allocate memory to hold the KeyObject
Dim cmd As String
Dim keyObjectLength As Long
cmd = "ObjectLength" & vbNullString
If BCryptGetProperty(hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bKeyObject() As Byte
ReDim bKeyObject(0 To keyObjectLength - 1)
'Calculate the block length for the IV, resize the IV
Dim ivLength As Long
Dim bIV() As Byte
cmd = "BlockLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bIV(0 To ivLength - 1)
RtlMoveMemory bIV(0), ByVal pIV, ivLength
'Set chaining mode
cmd = "ChainingMode" & vbNullString
Dim val As String
val = "ChainingModeCBC" & vbNullString
If BCryptSetProperty(hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0) <> 0 Then GoTo ErrHandler
'Create KeyObject using secret
Dim hKey As LongPtr
If BCryptGenerateSymmetricKey(hAlg, hKey, bKeyObject(1), keyObjectLength, ByVal pSecret, lenSecret, 0) <> 0 Then GoTo ErrHandler
'Calculate output buffer size, allocate output buffer
Dim OutputSize As Long
If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, OutputSize, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
Dim bDecrypted() As Byte
ReDim bDecrypted(0 To OutputSize - 1)
'Decrypt the data
Dim dataLength As Long
If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bDecrypted(0), OutputSize, dataLength, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
NGDecrypt = bDecrypted
'Cleanup
ExitHandler:
BCryptDestroyKey hKey
BCryptCloseAlgorithmProvider hAlg, 0
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
GoTo ExitHandler
End Function
Public Function NGDecryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
NGDecryptW = NGDecrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
End Function
Public Function EncryptData(inpData() As Byte, inpKey() As Byte) As Byte()
'SHA1 the key and data
Dim keyHash() As Byte
keyHash = HashBytes(inpKey, "SHA1")
Dim dataHash() As Byte
dataHash = HashBytes(inpData, "SHA1")
Dim dataLength As Long
dataLength = UBound(inpData) - LBound(inpData) + 1
Dim toEncrypt() As Byte
'To encrypt = Long (4 bytes) + dataLength + SHA1 (20 bytes)
ReDim toEncrypt(0 To dataLength + 23)
'Append length (in bytes) to start of array
RtlMoveMemory toEncrypt(0), dataLength, 4
'Then data
RtlMoveMemory toEncrypt(4), inpData(LBound(inpData)), dataLength
'Then hash of data
RtlMoveMemory toEncrypt(dataLength + 4), dataHash(0), 20
'Generate IV
Dim IV(0 To 15) As Byte
NGRandomW IV
'Encrypt data
Dim encryptedData() As Byte
encryptedData = NGEncrypt(VarPtr(toEncrypt(0)), dataLength + 24, VarPtr(IV(0)), 16, VarPtr(keyHash(0)), 16)
'Deallocate copy made to encrypt
Erase toEncrypt
'Extend encryptedData to append IV
ReDim Preserve encryptedData(LBound(encryptedData) To UBound(encryptedData) + 16)
'Append IV
RtlMoveMemory encryptedData(UBound(encryptedData) - 15), IV(0), 16
'Return result
EncryptData = encryptedData
End Function
Public Function DecryptData(inpData() As Byte, inpKey() As Byte, outDecrypted() As Byte) As Boolean
If LBound(inpData) <> 0 Then Exit Function 'Array must start at 0
Dim arrLength As Long
arrLength = UBound(inpData) + 1
'IV = 16 bytes, length = 4 bytes
If arrLength < 20 Then Exit Function
'SHA1 the key
Dim keyHash() As Byte
keyHash = HashBytes(inpKey, "SHA1")
'Get the pointer to the IV
Dim pIV As LongPtr
pIV = VarPtr(inpData(UBound(inpData) - 15)) 'Last 16 bytes = IV
'Decrypt the data
Dim decryptedData() As Byte
decryptedData = NGDecrypt(VarPtr(inpData(0)), UBound(inpData) - LBound(inpData) - 15, pIV, 16, VarPtr(keyHash(0)), 16)
'Check we got some data
If StrPtr(decryptedData) = 0 Then Exit Function ' Weirdly, this checks for uninitialized byte arrays
If UBound(decryptedData) < 3 Then Exit Function
'Get the data length
Dim dataLength As Long
RtlMoveMemory dataLength, decryptedData(0), 4
'Check if length is valid, with invalid key length = random data
If dataLength > (UBound(decryptedData) - 3) Or dataLength < 0 Then Exit Function
'Hash the decrypted data
Dim hashResult() As Byte
hashResult = NGHash(VarPtr(decryptedData(4)), dataLength, "SHA1")
'Verify the hash
Dim l As Byte
For l = 0 To 19
If hashResult(l) <> decryptedData(l + 4 + dataLength) Then
'Stored hash not equal to hash with decrypted data, key incorrect or encrypted data tampered with
'Don't touch output, return false by default
Exit Function
End If
Next
'Initialize output array
ReDim outDecrypted(0 To dataLength - 1)
'Copy data to output array
RtlMoveMemory outDecrypted(0), decryptedData(4), dataLength
DecryptData = True
End Function
Public Function EncryptString(inpString As String, inpKey As String) As String
Dim Data() As Byte
Data = inpString
Dim key() As Byte
key = inpKey
EncryptString = ToBase64(EncryptData(Data, key))
End Function
Public Function DecryptString(inpEncryptedString As String, inpKey As String) As String
Dim Data() As Byte
Data = Base64ToBytes(inpEncryptedString)
Dim key() As Byte
key = inpKey
Dim out() As Byte
DecryptData Data, key, out
DecryptString = out
End Function
并立即 window 轻松检查以查看其是否有效：
?EncryptString("Secret data", "Key") 'Returns seemingly random data, changing every call
?DecryptString(EncryptString("Secret data", "Other key"), "Other key")
'Test that long keys and long strings work, returns True since encrypted + decrypted = original
?DecryptString(EncryptString(String(100000, "A"), String(10000, "B")), String(10000, "B")) = String(100000, "A")
首先，我肯定会推荐 Erik 的路线，但是，直接回答你的问题，你的问题是，你生成了非 ASCII 字符的二进制数据。
然而，这可以通过使用 Base64 encoding/decoding 来解决，如下所示：
Sub WriteSettingsFile()
Dim db As DAO.Database
Dim fld As DAO.Field
Set db = CurrentDb
'Open Setings File name
Dim FilePath As String
Dim TextFile As Integer
TextFile = FreeFile
FilePath = Application.CurrentProject.Path & "\settings.cfg"
Open FilePath For Output As #TextFile
Print #TextFile, Encode64(szEncryptDecrypt("Hello World"))
Close #TextFile
End Sub
Sub ReadSettingsFile()
Dim strFilename As String
Dim strTextLine As String
Dim TextFile As Integer
TextFile = FreeFile
strFilename = Application.CurrentProject.Path & "\settings.cfg"
Open strFilename For Input As #TextFile
Do Until EOF(1)
Line Input #1, strTextLine
MsgBox strTextLine ' Not decrypted
MsgBox szEncryptDecrypt(Decode64(strTextLine)) ' Decrypted
Loop
Close #TextFile
End Sub
这需要两个辅助函数，然后你的代码开始有点堆积：
Option Compare Database
Option Explicit
Private Const clOneMask = 16515072 '000000 111111 111111 111111
Private Const clTwoMask = 258048 '111111 000000 111111 111111
Private Const clThreeMask = 4032 '111111 111111 000000 111111
Private Const clFourMask = 63 '111111 111111 111111 000000
Private Const clHighMask = 16711680 '11111111 00000000 00000000
Private Const clMidMask = 65280 '00000000 11111111 00000000
Private Const clLowMask = 255 '00000000 00000000 11111111
Private Const cl2Exp18 = 262144 '2 to the 18th power
Private Const cl2Exp12 = 4096 '2 to the 12th
Private Const cl2Exp6 = 64 '2 to the 6th
Private Const cl2Exp8 = 256 '2 to the 8th
Private Const cl2Exp16 = 65536 '2 to the 16th
Public Function Encode64(ByVal sString As String) As String
Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long
For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
bTrans(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
bTrans(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
bTrans(lTemp) = lTemp - 4 '1 - 0
Case 62
bTrans(lTemp) = 43 'Chr(43) = "+"
Case 63
bTrans(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables.
lPowers8(lTemp) = lTemp * cl2Exp8
lPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp
iPad = Len(sString) Mod 3 'See if the length is divisible by 3
If iPad Then 'If not, figure out the end pad and resize the input.
iPad = 3 - iPad
sString = sString & String(iPad, Chr(0))
End If
bIn = StrConv(sString, vbFromUnicode) 'Load the input string.
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
lTemp = lLen \ 72 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.
lLen = 0 'Reusing this one, so reset it.
For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set.
If lLen = 68 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar
If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If
Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.
End Function
Public Function Decode64(ByVal sString As String) As String
Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
Dim lTemp As Long
sString = Replace(sString, vbCr, vbNullString) 'Get rid of the vbCrLfs. These could be in...
sString = Replace(sString, vbLf, vbNullString) 'either order.
lTemp = Len(sString) Mod 4 'Test for valid input.
If lTemp Then
Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
End If
If InStrRev(sString, "==") Then 'InStrRev is faster when you know it's at the end.
iPad = 2 'Note: These translate to 0, so you can leave them...
ElseIf InStrRev(sString, "=") Then 'in the string and just resize the output.
iPad = 1
End If
For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
bTrans(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
bTrans(lTemp) = lTemp - 71 'a - z
Case 48 To 57
bTrans(lTemp) = lTemp + 4 '1 - 0
Case 43
bTrans(lTemp) = 62 'Chr(43) = "+"
Case 47
bTrans(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables.
lPowers6(lTemp) = lTemp * cl2Exp6
lPowers12(lTemp) = lTemp * cl2Exp12
lPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp
bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array.
ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1) 'Prepare the output buffer.
For lChar = 0 To UBound(bIn) Step 4
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte
lPos = lPos + 3
Next lChar
sOut = StrConv(bOut, vbUnicode) 'Convert back to a string.
If iPad Then sOut = Left$(sOut, Len(sOut) - iPad) 'Chop off any extra bytes.
Decode64 = sOut
End Function
输出：
我正在尝试加密文件。我不需要花哨的加密，只需要让视线远离它。我在网上找到了一个名为 szEncryptDecrypt (https://www.devx.com/tips/Tip/5676) 的函数，它非常适合我的需要，因为它使用简单，并且隐藏了数据。但是，从文件中读取时我似乎无法让它工作。在宏中将一个字符串传递给它并再次解密它工作正常，但写入文件然后读取它不起作用。
我有一个写子、一个读子和一个加密子。如果使用非加密数据，读写子似乎可以正常工作（除非它也得到隐藏字符）。
我在解密之前尝试了对字符串的 trim 函数，但是没有用。
Option Compare Database
Sub WriteSettingsFile()
Dim db As DAO.Database
Dim fld As DAO.Field
Set db = CurrentDb
'Open Setings File name
Dim filePath As String
Dim TextFile As Integer
TextFile = FreeFile
filePath = Application.CurrentProject.Path & "\settings.cfg"
Open filePath For Output As TextFile
Print #TextFile, szEncryptDecrypt("Hello World")
Close TextFile
End Sub
Sub ReadSettingsFile()
Dim strFilename As String
strFilename = Application.CurrentProject.Path & "\settings.cfg"
Dim strTextLine As String
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
Do Until EOF(1)
Line Input #1, strTextLine
MsgBox strTextLine 'Not Encrypted
MsgBox szEncryptDecrypt(strTextLine) 'Encrypted
Loop
Close #iFile
End Sub
Function szEncryptDecrypt(ByVal szData As String) As String
' This key value can be changed to alter the encryption,
' but it must be the same for both encryption and decryption.
Const KEY_TEXT As String = "asdfghjkl"
' The KEY_OFFSET is optional, and may be any value 0-64.
' Likewise, it needs to be the same coming/going.
Const KEY_OFFSET As Long = 0
Dim bytKey() As Byte
Dim bytData() As Byte
Dim lNum As Long
Dim szKey As String
For lNum = 1 To ((Len(szData) \ Len(KEY_TEXT)) + 1)
szKey = szKey & KEY_TEXT
Next lNum
bytKey = Left$(szKey, Len(szData))
bytData = szData
For lNum = LBound(bytData) To UBound(bytData)
If lNum Mod 2 Then
bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) + KEY_OFFSET)
Else
bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) - KEY_OFFSET)
End If
Next lNum
szEncryptDecrypt = bytData
End Function
Sub TestEncrypt()
'This sub works fine
Dim str As String
str = szEncryptDecrypt("Hello World!")
MsgBox "Encrypted" & vbNewLine & str
MsgBox "Decrypted" & vbNewLine & szEncryptDecrypt(str)
End Sub
有没有更好的文本文件加密功能？
是啊，你发现的那个加密函数很简单，但是很差。它使用偏移量进行简单的异或运算。这意味着如果有人可以让你加密一个已知的字符串并且可以读取输出，他们就可以计算出密钥。此外，没有链接，所以我们没有 diffusion，文本中重复的模式将导致相同的输出，因此可以推断出常见的模式。
我自己研究了一种复杂的加密方法，在 CBC 模式下使用 AES-128。但是，所需的代码相当长。它使用 CNG API 进行加密。其他人使用 .Net，后者又使用 CNG，但会导致代码更短。我不想这样做，因为它依赖于 COM 对象并且可以覆盖这些对象。
让我们从用法开始吧：很简单。使用 EncryptString(StringToEncrypt, Key) 加密字符串，然后使用 DecryptString(StringToDecrypt, Key) 再次解密。它使用 Base64 编码来表示加密的字符串，因此输出应该可以安全地存储在只接受有效 unicode 字符串的字段中（也与您找到的实现相反）。
然后是基础知识。 CBC 模式下的 AES-128 是一种块密码，因此它需要一个固定长度的密钥，并且还以 128 位的完整块进行加密。为了解决这个问题，我们使用 SHA1 将密钥减少到固定长度，并将输入数据的长度存储在加密字符串中以忽略任何填充（末尾的附加字符）。
然后，在CBC模式下，它还需要一个初始化向量（IV）。我们随机生成那个，并将它不加密地存储（因为我们需要它来解密）在字符串的末尾。由于我们随机生成 IV，用相同的密钥对相同的字符串加密两次将导致完全不同的加密字符串，这通常是可取的（如果你加密密码，你不希望有人能够检查谁都拥有和你一样的密码）。
此代码还对数据进行哈希处理，并将加密后的哈希值与数据一起存储。这意味着它可以轻松检查您的密钥是否有效，如果无效，它不会 return 任何东西。
生成的代码相当冗长。可以通过不在 VBA 中进行 Base64 编码、不使用密码安全的随机数生成器或对所有内容使用 .Net 来减少它，但这不是我想要的。我建议将其粘贴到单独的模块中。
Option Compare Binary
Option Explicit
Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Public Declare PtrSafe Function BCryptSetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbInput As Any, ByVal cbInput As Long, ByVal dfFlags As Long) As Long
Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Public Declare PtrSafe Function BCryptGenRandom Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, pbBuffer As Any, ByVal cbBuffer As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef hKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptEncrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDecrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyKey Lib "BCrypt.dll" (ByVal hKey As LongPtr) As Long
Public Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32.dll" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Const BCRYPT_BLOCK_PADDING As Long = &H1
Public Type QuadSextet
s1 As Byte
s2 As Byte
s3 As Byte
s4 As Byte
End Type
Public Function ToBase64(b() As Byte) As String
Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim l As Long
Dim output As String
Dim UBoundOut As Long
UBoundOut = UBound(b) + 1
If UBoundOut Mod 3 <> 0 Then
UBoundOut = UBoundOut + (3 - UBoundOut Mod 3)
End If
UBoundOut = (UBoundOut \ 3) * 4
output = String(UBoundOut, vbNullChar)
Dim qs As QuadSextet
For l = 0 To (UBound(b) - 2) \ 3
qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1), b(l * 3 + 2))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1)
Mid(output, (l * 4) + 4, 1) = Mid(Base64Table, qs.s4 + 1, 1)
Next
If UBound(b) + 1 - (l * 3) = 2 Then
qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1)
Mid(output, (l * 4) + 4, 1) = "="
ElseIf UBound(b) + 1 - (l * 3) = 1 Then
qs = BytesToQuadSextet(b(l * 3))
Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1)
Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1)
Mid(output, (l * 4) + 3, 2) = "=="
End If
ToBase64 = output
End Function
Public Function Base64ToBytes(strBase64 As String) As Byte()
Dim outBytes() As Byte
Dim lenBytes As Long
lenBytes = Len(strBase64) * 3 \ 4
If Right(strBase64, 1) = "=" Then lenBytes = lenBytes - 1
If Right(strBase64, 2) = "==" Then lenBytes = lenBytes - 1
ReDim outBytes(0 To lenBytes - 1)
Dim l As Long
Dim qs As QuadSextet
For l = 0 To lenBytes - 1
Select Case l Mod 3
Case 0
qs = Base64ToQuadSextet(Mid(strBase64, (l \ 3) * 4 + 1, 4))
outBytes(l) = qs.s1 * 2 ^ 2 + (qs.s2 \ 2 ^ 4)
Case 1
outBytes(l) = (qs.s2 * 2 ^ 4 And 255) + qs.s3 \ 2 ^ 2
Case 2
outBytes(l) = (qs.s3 * 2 ^ 6 And 255) + qs.s4
End Select
Next
Base64ToBytes = outBytes
End Function
Public Function BytesToQuadSextet(b1 As Byte, Optional b2 As Byte, Optional b3 As Byte) As QuadSextet
BytesToQuadSextet.s1 = b1 \ 4
BytesToQuadSextet.s2 = (((b1 * 2 ^ 6) And 255) \ 4) + b2 \ (2 ^ 4)
BytesToQuadSextet.s3 = (((b2 * 2 ^ 4) And 255) \ 4) + b3 \ (2 ^ 6)
BytesToQuadSextet.s4 = (((b3 * 2 ^ 2) And 255) \ 4)
End Function
Public Function Base64ToQuadSextet(strBase64 As String) As QuadSextet
Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Base64ToQuadSextet.s1 = InStr(Base64Table, Mid(strBase64, 1, 1)) - 1
Base64ToQuadSextet.s2 = InStr(Base64Table, Mid(strBase64, 2, 1)) - 1
Base64ToQuadSextet.s3 = InStr(Base64Table, Mid(strBase64, 3, 1)) - 1
Base64ToQuadSextet.s4 = InStr(Base64Table, Mid(strBase64, 4, 1)) - 1
End Function
Public Function StringToBase64(str As String) As String
StringToBase64 = ToBase64(StrConv(str, vbFromUnicode))
End Function
Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA1") As Byte()
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
End Function
Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
'Erik A, 2019
'Hash data by using the Next Generation Cryptography API
'Loosely based on https://docs.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
'Allowed algorithms: https://docs.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support
'Error handling not implemented!
On Error GoTo VBErrHandler
Dim errorMessage As String
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = HashingAlgorithm & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler
'Determine hash object size, allocate memory
Dim bHashObject() As Byte
Dim cmd As String
cmd = "ObjectLength" & vbNullString
Dim Length As Long
If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bHashObject(0 To Length - 1)
'Determine digest size, allocate memory
Dim hashLength As Long
cmd = "HashDigestLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bHash() As Byte
ReDim bHash(0 To hashLength - 1)
'Create hash object
Dim hHash As LongPtr
If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
'Hash data
If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
'Return result
NGHash = bHash
ExitHandler:
'Cleanup
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
If hHash <> 0 Then BCryptDestroyHash hHash
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Sub NGRandom(pData As LongPtr, lenData As Long, Optional Algorithm As String = "RNG")
'Erik A, 2019
'Fills data at pointer with random bytes
'Error handling not implemented!
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = Algorithm & vbNullChar
BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0
'Fill bytearray with random data
BCryptGenRandom hAlg, ByVal pData, lenData, 0
'Cleanup
BCryptCloseAlgorithmProvider hAlg, 0
End Sub
Public Sub NGRandomW(Data() As Byte, Optional Algorithm As String = "RNG")
If LBound(Data) = -1 Then Exit Sub
NGRandom VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, Algorithm
End Sub
Public Function NGEncrypt(pData As LongPtr, lenData As Long, inpIV As LongPtr, inpIVLength As Long, inpSecret As LongPtr, inpSecretLength As Long) As Byte()
'Encrypt pData using AES encryption, inpIV and inpSecret
'Input: pData -> mempointer to data. lenData: amount of bytes to encrypt. inpIV: mempointer to IV. inpSecret: mempointer to 128-bits secret.
'Output: Bytearray containing encrypted data
Dim errorMessage As String
On Error GoTo VBErrHandler
Dim hAlg As LongPtr
Dim algId As String
'Open algorithm provider
algId = "AES" & vbNullChar
BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0
'Allocate memory to hold the KeyObject
Dim cmd As String
Dim keyObjectLength As Long
cmd = "ObjectLength" & vbNullString
BCryptGetProperty hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0
Dim bKeyObject() As Byte
ReDim bKeyObject(0 To keyObjectLength - 1)
'Check block length = 128 bits, copy IV
Dim ivLength As Long
Dim bIV() As Byte
cmd = "BlockLength" & vbNullChar
BCryptGetProperty hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0
If ivLength > inpIVLength Then
Debug.Print
End If
ReDim bIV(0 To ivLength - 1)
RtlMoveMemory bIV(0), ByVal inpIV, ivLength
'Set chaining mode
cmd = "ChainingMode" & vbNullString
Dim val As String
val = "ChainingModeCBC" & vbNullString
BCryptSetProperty hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0
'Create KeyObject using secret
Dim hKey As LongPtr
BCryptGenerateSymmetricKey hAlg, hKey, bKeyObject(0), keyObjectLength, ByVal inpSecret, inpSecretLength, 0
'Calculate output buffer size, allocate output buffer
Dim cipherTextLength As Long
BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, cipherTextLength, BCRYPT_BLOCK_PADDING
Dim bCipherText() As Byte
ReDim bCipherText(0 To cipherTextLength - 1)
'Encrypt the data
Dim dataLength As Long
BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bCipherText(0), cipherTextLength, dataLength, BCRYPT_BLOCK_PADDING
'Output the encrypted data
NGEncrypt = bCipherText
ExitHandler:
'Destroy the key
If hKey <> 0 Then BCryptDestroyKey hKey
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Function NGEncryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
NGEncryptW = NGEncrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
End Function
Public Function NGDecrypt(pData As LongPtr, lenData As Long, pIV As LongPtr, lenIV As Long, pSecret As LongPtr, lenSecret As Long) As Byte()
Dim errorMessage As String
On Error GoTo VBErrHandler
Dim hAlg As LongPtr
Dim algId As String
'Open algorithm provider
algId = "AES" & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) <> 0 Then GoTo ErrHandler
'Allocate memory to hold the KeyObject
Dim cmd As String
Dim keyObjectLength As Long
cmd = "ObjectLength" & vbNullString
If BCryptGetProperty(hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bKeyObject() As Byte
ReDim bKeyObject(0 To keyObjectLength - 1)
'Calculate the block length for the IV, resize the IV
Dim ivLength As Long
Dim bIV() As Byte
cmd = "BlockLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bIV(0 To ivLength - 1)
RtlMoveMemory bIV(0), ByVal pIV, ivLength
'Set chaining mode
cmd = "ChainingMode" & vbNullString
Dim val As String
val = "ChainingModeCBC" & vbNullString
If BCryptSetProperty(hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0) <> 0 Then GoTo ErrHandler
'Create KeyObject using secret
Dim hKey As LongPtr
If BCryptGenerateSymmetricKey(hAlg, hKey, bKeyObject(1), keyObjectLength, ByVal pSecret, lenSecret, 0) <> 0 Then GoTo ErrHandler
'Calculate output buffer size, allocate output buffer
Dim OutputSize As Long
If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, OutputSize, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
Dim bDecrypted() As Byte
ReDim bDecrypted(0 To OutputSize - 1)
'Decrypt the data
Dim dataLength As Long
If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bDecrypted(0), OutputSize, dataLength, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
NGDecrypt = bDecrypted
'Cleanup
ExitHandler:
BCryptDestroyKey hKey
BCryptCloseAlgorithmProvider hAlg, 0
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
GoTo ExitHandler
End Function
Public Function NGDecryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
NGDecryptW = NGDecrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
End Function
Public Function EncryptData(inpData() As Byte, inpKey() As Byte) As Byte()
'SHA1 the key and data
Dim keyHash() As Byte
keyHash = HashBytes(inpKey, "SHA1")
Dim dataHash() As Byte
dataHash = HashBytes(inpData, "SHA1")
Dim dataLength As Long
dataLength = UBound(inpData) - LBound(inpData) + 1
Dim toEncrypt() As Byte
'To encrypt = Long (4 bytes) + dataLength + SHA1 (20 bytes)
ReDim toEncrypt(0 To dataLength + 23)
'Append length (in bytes) to start of array
RtlMoveMemory toEncrypt(0), dataLength, 4
'Then data
RtlMoveMemory toEncrypt(4), inpData(LBound(inpData)), dataLength
'Then hash of data
RtlMoveMemory toEncrypt(dataLength + 4), dataHash(0), 20
'Generate IV
Dim IV(0 To 15) As Byte
NGRandomW IV
'Encrypt data
Dim encryptedData() As Byte
encryptedData = NGEncrypt(VarPtr(toEncrypt(0)), dataLength + 24, VarPtr(IV(0)), 16, VarPtr(keyHash(0)), 16)
'Deallocate copy made to encrypt
Erase toEncrypt
'Extend encryptedData to append IV
ReDim Preserve encryptedData(LBound(encryptedData) To UBound(encryptedData) + 16)
'Append IV
RtlMoveMemory encryptedData(UBound(encryptedData) - 15), IV(0), 16
'Return result
EncryptData = encryptedData
End Function
Public Function DecryptData(inpData() As Byte, inpKey() As Byte, outDecrypted() As Byte) As Boolean
If LBound(inpData) <> 0 Then Exit Function 'Array must start at 0
Dim arrLength As Long
arrLength = UBound(inpData) + 1
'IV = 16 bytes, length = 4 bytes
If arrLength < 20 Then Exit Function
'SHA1 the key
Dim keyHash() As Byte
keyHash = HashBytes(inpKey, "SHA1")
'Get the pointer to the IV
Dim pIV As LongPtr
pIV = VarPtr(inpData(UBound(inpData) - 15)) 'Last 16 bytes = IV
'Decrypt the data
Dim decryptedData() As Byte
decryptedData = NGDecrypt(VarPtr(inpData(0)), UBound(inpData) - LBound(inpData) - 15, pIV, 16, VarPtr(keyHash(0)), 16)
'Check we got some data
If StrPtr(decryptedData) = 0 Then Exit Function ' Weirdly, this checks for uninitialized byte arrays
If UBound(decryptedData) < 3 Then Exit Function
'Get the data length
Dim dataLength As Long
RtlMoveMemory dataLength, decryptedData(0), 4
'Check if length is valid, with invalid key length = random data
If dataLength > (UBound(decryptedData) - 3) Or dataLength < 0 Then Exit Function
'Hash the decrypted data
Dim hashResult() As Byte
hashResult = NGHash(VarPtr(decryptedData(4)), dataLength, "SHA1")
'Verify the hash
Dim l As Byte
For l = 0 To 19
If hashResult(l) <> decryptedData(l + 4 + dataLength) Then
'Stored hash not equal to hash with decrypted data, key incorrect or encrypted data tampered with
'Don't touch output, return false by default
Exit Function
End If
Next
'Initialize output array
ReDim outDecrypted(0 To dataLength - 1)
'Copy data to output array
RtlMoveMemory outDecrypted(0), decryptedData(4), dataLength
DecryptData = True
End Function
Public Function EncryptString(inpString As String, inpKey As String) As String
Dim Data() As Byte
Data = inpString
Dim key() As Byte
key = inpKey
EncryptString = ToBase64(EncryptData(Data, key))
End Function
Public Function DecryptString(inpEncryptedString As String, inpKey As String) As String
Dim Data() As Byte
Data = Base64ToBytes(inpEncryptedString)
Dim key() As Byte
key = inpKey
Dim out() As Byte
DecryptData Data, key, out
DecryptString = out
End Function
并立即 window 轻松检查以查看其是否有效：
?EncryptString("Secret data", "Key") 'Returns seemingly random data, changing every call
?DecryptString(EncryptString("Secret data", "Other key"), "Other key")
'Test that long keys and long strings work, returns True since encrypted + decrypted = original
?DecryptString(EncryptString(String(100000, "A"), String(10000, "B")), String(10000, "B")) = String(100000, "A")
首先，我肯定会推荐 Erik 的路线，但是，直接回答你的问题，你的问题是，你生成了非 ASCII 字符的二进制数据。
然而，这可以通过使用 Base64 encoding/decoding 来解决，如下所示：
Sub WriteSettingsFile()
Dim db As DAO.Database
Dim fld As DAO.Field
Set db = CurrentDb
'Open Setings File name
Dim FilePath As String
Dim TextFile As Integer
TextFile = FreeFile
FilePath = Application.CurrentProject.Path & "\settings.cfg"
Open FilePath For Output As #TextFile
Print #TextFile, Encode64(szEncryptDecrypt("Hello World"))
Close #TextFile
End Sub
Sub ReadSettingsFile()
Dim strFilename As String
Dim strTextLine As String
Dim TextFile As Integer
TextFile = FreeFile
strFilename = Application.CurrentProject.Path & "\settings.cfg"
Open strFilename For Input As #TextFile
Do Until EOF(1)
Line Input #1, strTextLine
MsgBox strTextLine ' Not decrypted
MsgBox szEncryptDecrypt(Decode64(strTextLine)) ' Decrypted
Loop
Close #TextFile
End Sub
这需要两个辅助函数，然后你的代码开始有点堆积：
Option Compare Database
Option Explicit
Private Const clOneMask = 16515072 '000000 111111 111111 111111
Private Const clTwoMask = 258048 '111111 000000 111111 111111
Private Const clThreeMask = 4032 '111111 111111 000000 111111
Private Const clFourMask = 63 '111111 111111 111111 000000
Private Const clHighMask = 16711680 '11111111 00000000 00000000
Private Const clMidMask = 65280 '00000000 11111111 00000000
Private Const clLowMask = 255 '00000000 00000000 11111111
Private Const cl2Exp18 = 262144 '2 to the 18th power
Private Const cl2Exp12 = 4096 '2 to the 12th
Private Const cl2Exp6 = 64 '2 to the 6th
Private Const cl2Exp8 = 256 '2 to the 8th
Private Const cl2Exp16 = 65536 '2 to the 16th
Public Function Encode64(ByVal sString As String) As String
Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long
For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
bTrans(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
bTrans(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
bTrans(lTemp) = lTemp - 4 '1 - 0
Case 62
bTrans(lTemp) = 43 'Chr(43) = "+"
Case 63
bTrans(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables.
lPowers8(lTemp) = lTemp * cl2Exp8
lPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp
iPad = Len(sString) Mod 3 'See if the length is divisible by 3
If iPad Then 'If not, figure out the end pad and resize the input.
iPad = 3 - iPad
sString = sString & String(iPad, Chr(0))
End If
bIn = StrConv(sString, vbFromUnicode) 'Load the input string.
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
lTemp = lLen \ 72 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.
lLen = 0 'Reusing this one, so reset it.
For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set.
If lLen = 68 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar
If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If
Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.
End Function
Public Function Decode64(ByVal sString As String) As String
Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
Dim lTemp As Long
sString = Replace(sString, vbCr, vbNullString) 'Get rid of the vbCrLfs. These could be in...
sString = Replace(sString, vbLf, vbNullString) 'either order.
lTemp = Len(sString) Mod 4 'Test for valid input.
If lTemp Then
Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
End If
If InStrRev(sString, "==") Then 'InStrRev is faster when you know it's at the end.
iPad = 2 'Note: These translate to 0, so you can leave them...
ElseIf InStrRev(sString, "=") Then 'in the string and just resize the output.
iPad = 1
End If
For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
bTrans(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
bTrans(lTemp) = lTemp - 71 'a - z
Case 48 To 57
bTrans(lTemp) = lTemp + 4 '1 - 0
Case 43
bTrans(lTemp) = 62 'Chr(43) = "+"
Case 47
bTrans(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables.
lPowers6(lTemp) = lTemp * cl2Exp6
lPowers12(lTemp) = lTemp * cl2Exp12
lPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp
bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array.
ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1) 'Prepare the output buffer.
For lChar = 0 To UBound(bIn) Step 4
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte
lPos = lPos + 3
Next lChar
sOut = StrConv(bOut, vbUnicode) 'Convert back to a string.
If iPad Then sOut = Left$(sOut, Len(sOut) - iPad) 'Chop off any extra bytes.
Decode64 = sOut
End Function
输出：