Attribute VB_Name = "Module1"
Option Explicit
Option Base 0
' *******************************************************************************************
' Copyright (c) 2010 DI Management Services Pty Limited. All rights reserved.
' This code was originally written by David Ireland.
' Provided as is with no warranties. Use at your own risk.
' It is not to be altered or distributed, except as part of an application.
' You are free to use it in any application, provided the copyright notice is left unchanged.
' *******************************************************************************************
' Requires CryptoSys PKI version 3.5 or greater <www.cryptosys.net/pki>
' Include basCrPKI in your VBA project.
Sub Button1_Click()
Call Make_Signature
End Sub
Sub Button2_Click()
Call Verify_Signature
End Sub
Sub Button3_Click()
Call Clear_Verify
End Sub
Sub Sign_Button2_Click()
Call Clear_Sign
End Sub
Sub Sign_Button3_Click()
Call Copy_Data_From_Sign_To_Verify
End Sub
Public Function Verify_Signature()
Dim strMessage As String
Dim abData() As Byte
Dim abBlock() As Byte
Dim nBlockLen As Long
Dim nKeyLen As Long
Dim nMsgLen As Long
Dim nLen As Long
Dim nRet As Long
Dim strCertFile As String
Dim strPublicKey As String
Dim strSignatureBase64 As String
Dim abDigestFromSig() As Byte
Dim strDigestFromSig As String
Dim strDigest As String
Dim strResult As String
strResult = "ERROR"
Call Clear_Verify
' Get input from named cell in spreadsheet
strSignatureBase64 = Range("Signature_to_verify").Value & ""
If Len(strSignatureBase64) = 0 Then
MsgBox "Please enter the signature value", vbExclamation, "Missing Data"
Range("Signature_to_verify").Activate
GoTo Done
End If
' Original string
strMessage = Range("Message_to_verify_against").Value & ""
If Len(strMessage) = 0 Then
MsgBox "Require original string", vbExclamation, "Missing Data"
Range("Message_to_verify_against").Activate
GoTo Done
End If
' The certificate filename
strCertFile = Range("Certificate_file").Value & ""
If Len(strCertFile) = 0 Then
MsgBox "Please enter the filename of your public key certificate", vbExclamation, "Missing Data"
Range("Certificate_file").Activate
GoTo Done
End If
' Fix filename to CWD
strCertFile = ActiveWorkbook.Path & "\" & strCertFile
' Read in public key from certificate to an "internal" key string
nLen = RSA_GetPublicKeyFromCert("", 0, strCertFile, 0)
If nLen <= 0 Then
MsgBox "Cannot read certificate file: " & pkiErrorLookup(nLen)
GoTo Done
End If
' Pre-dimension string to receive key details
strPublicKey = String(nLen, " ")
' Now read it
nLen = RSA_GetPublicKeyFromCert(strPublicKey, Len(strPublicKey), strCertFile, 0)
' DEBUGGING...
''Range("Input_signature_in_hex").Value = strPublicKey
' Block length is same size as the key in bytes
nKeyLen = RSA_KeyBytes(strPublicKey)
If nKeyLen <= 0 Then
MsgBox "Error with the public key: " & pkiErrorLookup(nKeyLen)
GoTo Done
End If
' Display key size in bits
Range("Key_size_in_bits").Value = RSA_KeyBits(strPublicKey)
' Decode signature block from base64
abBlock = cnvBytesFromB64Str(strSignatureBase64)
nBlockLen = UBound(abBlock) + 1
' Display it
Range("Input_signature_in_hex").Value = cnvHexStrFromBytes(abBlock)
' Check size matches public key size
If nBlockLen <> nKeyLen Then
MsgBox "ERROR: signature size does not match public key length", vbCritical
GoTo Done
End If
' Now "decrypt" the signature block using the RSA public key
nRet = RSA_RawPublic(abBlock(0), nBlockLen, strPublicKey, 0)
' Display it
Range("Decrypted_signature_block").Value = cnvHexStrFromBytes(abBlock)
' Extract the message digest from this block (it should be the same size as an SHA-1 digest in BYTES)
nLen = PKI_SHA1_BYTES
ReDim abDigestFromSig(nLen - 1)
nLen = RSA_DecodeMsg(abDigestFromSig(0), nLen, abBlock(0), nBlockLen, PKI_EMSIG_PKCSV1_5)
If nLen < 0 Then
strResult = "Invalid signature"
GoTo Done
End If
' Convert this to hex
strDigestFromSig = UCase(cnvHexStrFromBytes(abDigestFromSig))
' Display it
Range("Digest_from_signature").Value = strDigestFromSig
' Now compute the SHA-1 digest of the original message - it must match
strDigest = String(PKI_SHA1_CHARS, " ")
nRet = HASH_HexFromString(strDigest, Len(strDigest), strMessage, Len(strMessage), PKI_HASH_SHA1)
strDigest = UCase(strDigest)
' Display it
Range("Message_digest").Value = strDigest
' Compare the two digests
If strDigest = strDigestFromSig Then
strResult = "OK"
Else
strResult = "Invalid signature"
End If
Done:
' Finally, display the result - either "OK" or "Invalid signature"
Range("Result").Value = strResult
Verify_Signature = strResult
Exit Function
HandleError:
MsgBox "An error has occurred: " & Err.Number & ": " & Err.Description
Resume Done
End Function
Public Sub Clear_Verify()
' Clear all working fields on the "Verify" sheet
Range("Result").Value = ""
Range("Verify!Key_size_in_bits").Value = ""
Range("Input_signature_in_hex").Value = ""
Range("Decrypted_signature_block").Value = ""
Range("Digest_from_signature").Value = ""
Range("Message_digest").Value = ""
End Sub
Public Sub Clear_Sign()
' Clear all working fields on the "Sign" sheet
Range("Key_size_in_bits").Value = ""
Range("Signature_base64").Value = ""
Range("Input_block_to_signature").Value = ""
Range("Signature_in_hex").Value = ""
End Sub
Public Sub Copy_Data_From_Sign_To_Verify()
Call Clear_Verify
Range("Signature_to_verify").Value = Range("Signature_base64").Value
Range("Message_to_verify_against").Value = Range("Input_text_to_sign").Value
Sheets("Verify").Activate
Range("Signature_to_verify").Activate
End Sub
Public Function Make_Signature() As String
On Error GoTo HandleError
Dim strMessage As String
Dim abData() As Byte
Dim abBlock() As Byte
Dim nBlockLen As Long
Dim nMsgLen As Long
Dim nLen As Long
Dim nRet As Long
Dim strKeyFile As String
Dim strPassword As String
Dim strPrivateKey As String
Dim strSignatureBase64 As String
Call Clear_Sign
' Get input from named cell in spreadsheet
strMessage = Range("Input_text_to_sign").Value & ""
If Len(strMessage) = 0 Then
MsgBox "No input text!", vbExclamation, "Missing Data"
Range("Input_text_to_sign").Activate
GoTo Done
End If
''Range("Input_block_to_signature").Value = strMessage
' The private key filename
strKeyFile = Range("Private_key_file").Value & ""
If Len(strKeyFile) = 0 Then
MsgBox "Please enter the filename of your private key", vbExclamation, "Missing Data"
Range("Private_key_file").Activate
GoTo Done
End If
' and the password
strPassword = Range("Password").Value & ""
If Len(strPassword) = 0 Then
MsgBox "Please enter the password", vbExclamation, "Missing Data"
Range("Password").Activate
GoTo Done
End If
' Fix filename to CWD
strKeyFile = ActiveWorkbook.Path & "\" & strKeyFile
' Read in keyfile to an "internal" key string
nLen = RSA_ReadEncPrivateKey("", 0, strKeyFile, strPassword, 0)
If nLen <= 0 Then
MsgBox "Cannot read private file: " & pkiErrorLookup(nLen)
GoTo Done
End If
' Pre-dimension string to receive key details
strPrivateKey = String(nLen, " ")
' Now read it
nLen = RSA_ReadEncPrivateKey(strPrivateKey, Len(strPrivateKey), strKeyFile, strPassword, 0)
'''Range("Signature_in_hex").Value = strPrivateKey
' Block length is same size as the key in bytes
nBlockLen = RSA_KeyBytes(strPrivateKey)
If nBlockLen <= 0 Then
MsgBox "Error with the private key: " & pkiErrorLookup(nBlockLen)
GoTo Done
End If
' Display key size in bits
Range("Key_size_in_bits").Value = RSA_KeyBits(strPrivateKey)
' Convert message string to array of bytes
abData = StrConv(strMessage, vbFromUnicode)
nMsgLen = UBound(abData) + 1
' Encode (pad) data for RSA signature block using default SHA-1
ReDim abBlock(nBlockLen - 1)
nRet = RSA_EncodeMsg(abBlock(0), nBlockLen, abData(0), nMsgLen, PKI_EMSIG_PKCSV1_5)
' Display block in hex
Range("Input_block_to_signature").Value = cnvHexStrFromBytes(abBlock)
' Now we sign it using RSA private key
nRet = RSA_RawPrivate(abBlock(0), nBlockLen, strPrivateKey, 0)
' Now we display it in both hex and base64 encoded forms
Range("Signature_in_hex").Value = cnvHexStrFromBytes(abBlock)
Range("Signature_base64").Value = cnvB64StrFromBytes(abBlock)
' Return base64-encoded signature value
strSignatureBase64 = cnvB64StrFromBytes(abBlock)
Make_Signature = strSignatureBase64
Done:
' TODO: wipe key and password data here...
Exit Function
HandleError:
MsgBox "An error has occurred: " & Err.Number & ": " & Err.Description
Resume Done
End Function