Option Explicit
Option Base 0

' frmCryptoSys.frm
' A demonstration of some of the encryption functions in the CryptoSys(tm) API.

'********************* COPYRIGHT NOTICE*********************
' Copyright (c) 2001-6 DI Management Services Pty Limited.
' All rights reserved.
' This code is provided as a suggested interface to the CryptoSys API.
' Use at your own risk. Make your own tests and check that this code
' does what you expect. Please report any bugs to <www.di-mgt.com.au>
' The latest version of CryptoSys(tm) API and a licence
' may be obtained from <www.cryptosys.net>.
' This copyright notice must always be left intact.
'************** END OF COPYRIGHT NOTICE*********************

' NOTE: Because this tries to do everything, it's more
' complicated than you'd need in a normal implementation.

' CAUTION: This is just a test-bed demo. It is not meant to be
' represesentative of good security code practices.
' There are limited error handling facilities, too.

' Invalid-length keys and IVs entered by the user are just padded with zeroes
' to avoid failures - don't do this in practice!

' REVISION HISTORY:
' Jul 2006: Substantial revision for v3.2
' Jan 2006: minor update for v3.1.
' Feb 2005: minor update.
' Sep 2001: First published.
' ****************

Private Sub cmdClose_Click()
    End
End Sub

Private Sub cmdEncrypt_Click()
' Encrypt the plain text as required using hex strings
#If Not cccDebug Then
    On Error GoTo HandleError
#End If
    Dim nBlkLen As Long
    Dim nRet As Long
    Dim sMode As String
    Dim strPlain As String
    Dim strCipher As String
    Dim strHexKey As String
    Dim strHexIV As String
    
    ' Get current values for key and IV
    strHexKey = SetKey()
    strHexIV = SetIV()
    
    ' Clear output
    Me.txtInputBlock = ""
    Me.txtCipher = ""
    Me.txtCipherHex = ""
    Me.txtCipher64 = ""
    
    ' Convert plain text into hex if necessary
    If Me.optPTAlpha Then
        strPlain = cnvHexStrFromString(Me.txtPlain)
    Else
        If Not IsValidHex(Me.txtPlain) Then
            MsgBox "Invalid hex in plain text"
            GoTo Done
        End If
        strPlain = Me.txtPlain
    End If
    
    ' Get block length for chosen cipher
    nBlkLen = GetBlockLen()
    
    ' Then pad input if required
    If NeedPadding() Then
        strPlain = padHexString(strPlain, nBlkLen)
    End If
    
    ' Show input data as hex
    Me.txtInputBlock = strPlain
    
    ' Set up output string to required length
    strCipher = String(Len(strPlain), " ")
    
    ' Get the current mode
    sMode = GetMode()
    
    ' Now encrypt as per algorithm
    If Me.optDES.Value Then
        nRet = DES_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    ElseIf Me.optTDEA.Value Then
        nRet = TDEA_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    ElseIf Me.optAES128 Then
        nRet = AES128_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    ElseIf Me.optAES192 Then
        nRet = AES192_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    ElseIf Me.optAES256 Then
        nRet = AES256_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    ElseIf Me.optBLF Then
        nRet = BLF_HexMode(strCipher, strPlain, strHexKey, ENCRYPT, sMode, strHexIV)
    End If
    
    If nRet <> 0 Then
        Call DisplayCryptoSysError(nRet)
        Exit Sub
    End If

    ' Display results in hex, "raw" and base64 format
    Me.txtCipherHex = strCipher
    Me.txtCipher = cnvStringFromHexStr(strCipher)
    Me.txtCipher64 = cnvB64StrFromBytes(cnvBytesFromHexStr(strCipher))
    Me.cmdDecrypt.Enabled = True
    
Done:
    Exit Sub
HandleError:
    Call HandleVBError
    Resume Done

End Sub

Private Sub cmdDecrypt_Click()
' Decrypt the cipher text using hex strings
#If Not cccDebug Then
    On Error GoTo HandleError
#End If
    Dim nBlockLen As Long
    Dim nRet As Long
    Dim sMode As String
    Dim strCipher As String
    Dim strOutputHex As String
    Dim strDecrypt As String
    Dim strHexKey As String
    Dim strHexIV As String
    
    nBlockLen = GetBlockLen()
    
    ' Get current values for key and IV
    strHexKey = SetKey()
    strHexIV = SetIV()
    
    ' Clear output
    Me.txtDecrypt = ""
    Me.txtDecryptHex = ""
    Me.txtOutputBlock = ""
    
    ' Get the current ciphertext in hex format
    strCipher = Me.txtCipherHex
    strOutputHex = String(Len(strCipher), " ")
    
    ' Get the current mode
    sMode = GetMode()
   
    ' Now decrypt as per current algorithm
    If Me.optDES.Value Then
        nRet = DES_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    ElseIf Me.optTDEA.Value Then
        nRet = TDEA_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    ElseIf Me.optAES128 Then
        nRet = AES128_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    ElseIf Me.optAES192 Then
        nRet = AES192_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    ElseIf Me.optAES256 Then
        nRet = AES256_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    ElseIf Me.optBLF Then
        nRet = BLF_HexMode(strOutputHex, strCipher, strHexKey, DECRYPT, sMode, strHexIV)
    End If
    
    ' Check whether OK
    If nRet <> 0 Then
        Call DisplayCryptoSysError(nRet)
        Exit Sub
    End If
    
    ' Show the unpadded output block
    Me.txtOutputBlock = strOutputHex
    
    ' Strip padding if nec
    If NeedPadding() Then
        strDecrypt = unpadHexString(strOutputHex, nBlockLen)
        If Len(strDecrypt) = Len(strOutputHex) Then
            MsgBox "Decryption error - invalid padding bytes found"
            Exit Sub
        End If
    Else
        strDecrypt = strOutputHex
    End If
    
    ' Display output in HEX and ANSI format
    Me.txtDecryptHex = strDecrypt
    Me.txtDecrypt = cnvStringFromHexStr(strDecrypt)
    
Done:
    Exit Sub
HandleError:
    Call HandleVBError
    Resume Done
    
End Sub

Private Sub cmdGenIV_Click()
    Call GenerateIV
End Sub

Private Sub cmdGenKey_Click()
    ' Generate a random key silently
    Call GenerateKey("")
End Sub

Private Sub cmdGenKeyPrompt_Click()
    ' Generate a random key with user prompt
    Dim strSeed As String
    
    ' Ask user to type in some seed characters
    strSeed = InputBox("Please type some characters:")
    
    Call GenerateKey(strSeed)
End Sub

Private Sub GenerateKey(strSeed As String)
    ' Generate a random key
    Dim sHexKey As String
    Dim nBytes As Long
    
    ' What length key do we need?
    If Me.optDES.Value Then
        nBytes = 8
    ElseIf Me.optTDEA.Value Then
        nBytes = 24
    ElseIf Me.optAES128 Then
        nBytes = 16
    ElseIf Me.optAES192 Then
        nBytes = 24
    ElseIf Me.optAES256 Then
        nBytes = 32
    Else
        ' Set to 16 byte length by default
        nBytes = 16
    End If
    
    ' Pad hex-encoded key to *DOUBLE* byte-length
    sHexKey = String(2 * nBytes, " ")
    Call RNG_KeyHex(sHexKey, Len(sHexKey), nBytes, strSeed, Len(strSeed))
    
    Me.optHexKey = True
    Me.txtKey = sHexKey
    Me.txtKeyAsString.Text = sHexKey
    ' Allow encrypt
    Me.cmdEncrypt.Enabled = True
    ' Put user in plaintext box
    Me.txtPlain.SetFocus

End Sub

Private Sub GenerateIV()
    ' Generate a random key
    Dim sHexIV As String
    Dim nBytes As Long
    
    ' What length IV do we need?
    nBytes = GetBlockLen()
    
    ' Pad hex to *DOUBLE* byte-length
    sHexIV = rngNonceHex(nBytes)
    
    Me.txtIV = sHexIV
    
End Sub

Private Sub cmdSetKey_Click()
    Call SetKey
    Call SetIV
End Sub
    
Private Function SetKey() As String
' Set key as a hex string
    Dim nKeyLen As Long
    Dim nPad As Long
    Dim strKey As String

    ' What format is the key in?
    If Me.optHexKey Then
        If IsValidHex(Me.txtKey) Then
            strKey = Me.txtKey
        Else
            MsgBox "Key is not valid hex"
            Me.txtKey.SetFocus
            GoTo Done
        End If
    Else
        ' User has provided a plain alpha string
        strKey = cnvHexStrFromString(Me.txtKey)
    End If
    
    ' Now pad key with zeroes as per algorithm
    If Me.optDES.Value Then
        nKeyLen = 8
    ElseIf Me.optTDEA.Value Then
        nKeyLen = 24
    ElseIf Me.optAES128 Then
        nKeyLen = 16
    ElseIf Me.optAES192 Then
        nKeyLen = 24
    ElseIf Me.optAES256 Then
        nKeyLen = 32
    Else
        nKeyLen = Len(strKey) \ 2
    End If
    
    ' Catch zero key length - default to 16 bytes
    If nKeyLen = 0 Then nKeyLen = 16
    
    ' nKeyLen is # of bytes - we want len of hex string
    nPad = nKeyLen * 2 - Len(strKey)
    If nPad > 0 Then
        strKey = strKey & String(nPad, "0")
    ElseIf nPad < 0 Then
        strKey = Left(strKey, nKeyLen * 2)
    End If
    
    ' Show key
    Me.txtKeyAsString = strKey
    ' Allow encrypt
    Me.cmdEncrypt.Enabled = True
    ' Put user in plaintext box
    Me.txtPlain.SetFocus
    
    SetKey = strKey
    
Done:

End Function

Private Function SetIV() As String
' Set IV and show value in current IV box
    Dim strHexIV As String
    
    ' Do we need an IV? If not, clear current value
    If Not NeedIV() Then
        strHexIV = ""
        Me.txtIVAsString = strHexIV
        GoTo Done
    Else
        strHexIV = Me.txtIV
    End If
    
    ' Now pad IV with zeroes to match algorithm block length
    strHexIV = FixHexLength(strHexIV, GetBlockLen())
    
    ' Show IV
    Me.txtIVAsString = strHexIV
    
    SetIV = strHexIV
    
Done:

End Function

Private Function FixHexLength(strInputHex As String, nBytes As Long) As String
' Given a hex string, either pad with zeroes to make up to nBytes long or truncate.
    Dim nPad As Long
    
    nPad = nBytes * 2 - Len(strInputHex)
    If nPad > 0 Then
        FixHexLength = strInputHex & String(nPad, "0")
    ElseIf nPad < 0 Then
        FixHexLength = Left(strInputHex, nBytes * 2)
    Else
        FixHexLength = strInputHex
    End If

End Function

Private Function GetMode() As String
' Return the required string for the current mode
    If Me.optModeCBC Then
        GetMode = "CBC"
    ElseIf Me.optModeCTR Then
        GetMode = "CTR"
    Else    ' Default
        GetMode = "ECB"
    End If
End Function

Private Function NeedIV() As Boolean
' All modes except ECB require an IV
    NeedIV = (GetMode() <> "ECB")
End Function

Private Function NeedPadding() As Boolean
' We need padding if the user has asked for it AND we are in ECB or CBC mode
    Dim sMode As String
    sMode = GetMode()
    NeedPadding = (Me.optPad = True) And (sMode = "ECB" Or sMode = "CBC")
End Function

Private Function GetBlockLen()
' Return length in bytes of current algorithm's block size
' Note use of constants from basCryptoSys.bas
    If Me.optDES.Value Then
        GetBlockLen = API_BLK_DES_BYTES
    ElseIf Me.optTDEA.Value Then
        GetBlockLen = API_BLK_TDEA_BYTES
    ElseIf Me.optBLF.Value Then
        GetBlockLen = API_BLK_BLF_BYTES
    ElseIf Me.optAES128 Then
        GetBlockLen = API_BLK_AES_BYTES
    ElseIf Me.optAES192 Then
        GetBlockLen = API_BLK_AES_BYTES
    ElseIf Me.optAES256 Then
        GetBlockLen = API_BLK_AES_BYTES
    Else    ' default
        GetBlockLen = 8
    End If
End Function

Private Function IsValidHex(strToCheck As String)
' Returns True if strToCheck only contains valid hexadecimal digits
    Const scHEXDIGITS As String = "0123456789ABCDEFabcdef"
    ' NB Include both uc and lc just in case Binary Compare mode
    Dim i As Integer
    Dim nLen As Long

    IsValidHex = True
    nLen = Len(strToCheck)
    For i = 1 To nLen
        If InStr(scHEXDIGITS, Mid(strToCheck, i, 1)) = 0 Then
            IsValidHex = False
            Exit For
        End If
    Next
End Function

Private Sub HandleVBError()
' Display error message after unexpected VB error
    Dim sMsg As String
    sMsg = "VB error " & Err.Number & " has occurred:" & vbCrLf & vbCrLf & Err.Description
    MsgBox sMsg, vbCritical, "VB Error Handler"
End Sub

Private Sub DisplayCryptoSysError(nRet As Long)
    MsgBox "CryptoSys error " & nRet & " has occurred: " _
        & vbCrLf & vbCrLf & apiErrorLookup(nRet), vbExclamation, "CryptoSys Error"
End Sub