0
こんにちは、私は32ビットOffice Ambient（Access 2010）でうまく動作するVBAモジュールを持っています。 64ビットOffice Ambientでも正しく動作するようにコードを調整する必要があります。詳細はAccess 2010で使用するAdaptec Crypto API（VBA）64ビット
iは
プライベート宣言機能CryptGetProvParamのLib「のAdvapi32.dll」.... プライベート宣言機能CryptDeriveKeyのLib「のAdvapi32.dll」のためのハンドルとデータ型の構造を理解することはできません... 。 プライベート宣言機能CryptEncryptのLib "のAdvapi32.dll" ...... プライベート宣言機能CryptDestroyKeyのLib "のAdvapi32.dll" ... プライベート宣言機能CryptDecryptのLib "のAdvapi32.dll" .....
私はインターネットで何度も探してきましたが、Crypto APIの詳細を理解するための参照が見つかりませんでした 関数。
お時間をいただきありがとうございます。
：コードを定義しましたが、tuはうまく動作しますが、少し問題があります。 コードは32ビットバージョンではうまく動作しますが、64ビットバージョンでは、3文字以上の長さの文字列を復号化するために渡すときに、誤った復号化文字列を生成します。 2文字または3文字の文字列長を渡すと、decryptは正しいキーを生成しますが、4文字以上を渡すと毎回別の文字列が生成されます。
この次のコードは、正しい結果を生成
EncryptionCSPConnect sEncrypted = EncryptData（ "AA"、MY_PASSWORD） EncryptionCSPDisconnect
EncryptionCSPConnect sDecrypted = DecryptData（sEncrypted、MY_PASSWORD） EncryptionCSPDisconnect
この次のコードが不正確な結果を生成する
EncryptionCSPConnect sEncrypted = EncryptData（ "例えば"、MY_PASSWORD） EncryptionCSPDisconnect
EncryptionCSPConnect sDecrypted = DecryptData（sEncrypted、MY_PASSWORD） EncryptionCSPDisconnect
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
(ByRef phProv As LongPtr, ByVal pszContainer As String, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As LongPtr, ByVal algid As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, _
ByRef phHash As LongPtr) As Boolean
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" _
(ByVal hHash As LongPtr, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" _
(ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptDeriveKey Lib "advapi32.dll" _
(ByVal hProv As LongPtr, ByVal algid As Long, ByVal hBaseData As LongPtr, ByVal dwFlags As Long, _
ByRef phKey As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyKey Lib "advapi32.dll" _
(ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function CryptEncrypt Lib "advapi32.dll" _
(ByVal hKey As LongPtr, ByVal hHash As LongPtr, ByVal Final As Boolean, ByVal dwFlags As Long, _
ByVal pbData As String, ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare PtrSafe Function CryptDecrypt Lib "advapi32.dll" _
(ByVal hKey As LongPtr, _
ByVal hHash As LongPtr, _
ByVal Final As Boolean, _
ByVal dwFlags As Long, _
ByVal pbData As String, _
ByRef pdwDataLen As Long) As Boolean
Private Declare PtrSafe Function CryptGetProvParam Lib "advapi32.dll" _
(ByVal hProv As LongPtr, _
ByVal dwParam As Long, _
ByRef pbData As Any, _
ByRef pdwDataLen As Long, _
ByVal dwFlags As Long) As Long
#Else
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
(ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, _
ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
(ByVal hHash As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
(ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, _
ByRef phKey As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function CryptEncrypt Lib "advapi32.dll" _
(ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, _
ByVal pbData As String, ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32.dll" _
(ByVal hKey As Long, _
ByVal hHash As Long, _
ByVal Final As Long, _
ByVal dwFlags As Long, _
ByVal pbData As String, _
ByRef pdwDataLen As Long) As Long
Private Declare Function CryptGetProvParam Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal dwParam As Long, _
ByRef pbData As Any, _
ByRef pdwDataLen As Long, _
ByVal dwFlags As Long) As Long
#End If
Private Const SERVICE_PROVIDER As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const KEY_CONTAINER As String = "Metallica"
Private Const PROV_RSA_FULL As Long = 1
Private Const PP_NAME As Long = 4
Private Const PP_CONTAINER As Long = 6
Private Const CRYPT_NEWKEYSET As Long = 8
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_MD5 As Long = 3
Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
Private Const ENCRYPT_ALGORITHM As Long = CALG_RC4
Private Const NUMBER_ENCRYPT_PASSWORD As String = "´o¸sçPQ]"
#If VBA7 And Win64 Then
Private hCryptProv As LongPtr
#Else
Private hCryptProv As Long
#End If
Public Function EncryptionCSPConnect() As Boolean
'Function Adapted
'Get handle to CSP
If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then
If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then
HandleError "Error during CryptAcquireContext for a new key container." & vbCrLf & _
"A container with this name probably already exists."
EncryptionCSPConnect = False
Exit Function
End If
End If
EncryptionCSPConnect = True
End Function
Public Sub EncryptionCSPDisconnect()
'Release provider handle.
'Function Adapted
If hCryptProv <> 0 Then
CryptReleaseContext hCryptProv, 0
End If
End Sub
Public Function EncryptData(ByVal data As String, ByVal Password As String) As String
Dim sEncrypted As String
Dim lEncryptionCount As Long
Dim sTempPassword As String
'It is possible that the normal encryption will give you a string
'containing cr or lf characters which make it difficult to write to files
'Do a loop changing the password and keep encrypting until the result is ok
'To be able to decrypt we need to also store the number of loops in the result
'Try first encryption
lEncryptionCount = 0
sTempPassword = Password & lEncryptionCount
sEncrypted = EncryptDecrypt(data, sTempPassword, True)
'Loop if this contained a bad character
Do While (InStr(1, sEncrypted, vbCr) > 0) _
Or (InStr(1, sEncrypted, vbLf) > 0) _
Or (InStr(1, sEncrypted, Chr$(0)) > 0) _
Or (InStr(1, sEncrypted, vbTab) > 0)
'Try the next password
lEncryptionCount = lEncryptionCount + 1
sTempPassword = Password & lEncryptionCount
sEncrypted = EncryptDecrypt(data, sTempPassword, True)
'Don't go on for ever, 1 billion attempts should be plenty
If lEncryptionCount = 99999999 Then
Err.Raise vbObjectError + 999, "EncryptData", "This data cannot be successfully encrypted"
EncryptData = ""
Exit Function
End If
Loop
'Build encrypted string, starting with number of encryption iterations
EncryptData = EncryptNumber(lEncryptionCount) & sEncrypted
End Function
Public Function DecryptData(ByVal data As String, ByVal Password As String) As String
Dim lEncryptionCount As Long
Dim sDecrypted As String
Dim sTempPassword As String
'When encrypting we may have gone through a number of iterations
'How many did we go through?
lEncryptionCount = DecryptNumber(Mid$(data, 1, 8))
'start with the last password and work back
sTempPassword = Password & lEncryptionCount
sDecrypted = EncryptDecrypt(Mid$(data, 9), sTempPassword, False)
DecryptData = sDecrypted
End Function
Public Function GetCSPDetails() As String
Dim lLength As Long
Dim yContainer() As Byte
If hCryptProv = 0 Then
GetCSPDetails = "Not connected to CSP"
Exit Function
End If
'For developer info, show what the CSP & container name is
lLength = 1000
ReDim yContainer(lLength)
If CryptGetProvParam(hCryptProv, PP_NAME, yContainer(0), lLength, 0) <> 0 Then
GetCSPDetails = "Cryptographic Service Provider name: " & ByteToStr(yContainer, lLength)
End If
lLength = 1000
ReDim yContainer(lLength)
If CryptGetProvParam(hCryptProv, PP_CONTAINER, yContainer(0), lLength, 0) <> 0 Then
GetCSPDetails = GetCSPDetails & vbCrLf & "Key Container name: " & ByteToStr(yContainer, lLength)
End If
End Function
Private Function EncryptDecrypt(ByVal data As String, ByVal Password As String, ByVal encrypt As Boolean) As String
#If Win64 Then
Dim hHash As LongPtr
Dim hKey As LongPtr
Dim hHashNull As LongPtr
Dim hKeyNull As LongPtr
hHashNull = 0&
hKeyNull = 0&
#Else
Dim hHash As Long
Dim hKey As Long
Dim hHashNull As Long
Dim hKeyNull As Long
#End If
Dim lLength As Long
Dim sTemp As String
Dim GetValue As Boolean
If hCryptProv = 0 Then
HandleError "Not connected to CSP"
Exit Function
End If
'--------------------------------------------------------------------
'The data will be encrypted with a session key derived from the
'password.
'The session key will be recreated when the data is decrypted
'only if the password used to create the key is available.
'--------------------------------------------------------------------
'Create a hash object.
GetValue = CryptCreateHash(hCryptProv, CALG_MD5, hKeyNull, 0, hHash)
If GetValue = False Then
HandleError "Error during CryptCreateHash!"
End If
'Hash the password.
If CryptHashData(hHash, Password, Len(Password), 0) = 0 Then
HandleError "Error during CryptHashData."
End If
'Derive a session key from the hash object.
If CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 0 Then
HandleError "Error during CryptDeriveKey!"
End If
'Do the work
sTemp = data
lLength = Len(data)
If encrypt Then
'Encrypt data.
If CryptEncrypt(hKey, hHashNull, True, 0, sTemp, lLength, lLength) = 0 Then
HandleError "Error during CryptEncrypt."
End If
Else
'Encrypt data.
GetValue = CryptDecrypt(hKey, hHashNull, True, 0, sTemp, lLength)
If GetValue = 0 Then
HandleError "Error during CryptDecrypt."
End If
End If
'This is what we return.
EncryptDecrypt = Mid$(sTemp, 1, lLength)
'Destroy session key.
If hKey <> 0 Then
CryptDestroyKey hKey
End If
'Destroy hash object.
If hHash <> 0 Then
CryptDestroyHash hHash
End If
End Function
Private Sub HandleError(ByVal error As String)
'You could write the error to the screen or to a file
Debug.Print error
End Sub
Private Function ByteToStr(ByRef ByteArray() As Byte, ByVal lLength As Long) As String
Dim i As Long
For i = LBound(ByteArray) To (LBound(ByteArray) + lLength)
ByteToStr = ByteToStr & Chr$(ByteArray(i))
Next i
End Function
Private Function EncryptNumber(ByVal lNumber As Long) As String
Dim i As Long
Dim sNumber As String
sNumber = Format$(lNumber, "00000000")
For i = 1 To 8
EncryptNumber = EncryptNumber & Chr$(Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)) + Val(Mid$(sNumber, i, 1)))
Next i
End Function
Private Function DecryptNumber(ByVal sNumber As String) As Long
Dim i As Long
For i = 1 To 8
DecryptNumber = (10 * DecryptNumber) + (Asc(Mid$(sNumber, i, 1)) - Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)))
Next i
End Function