Attribute VB_Name = "basMySecret"
Option Explicit
Option Base 0

' $Id: basMySecret $

'****************************************************************************
' Copyright (C)2007 DI Management Services Pty Limited, All Rights Reserved.
'****************************************************************************
' Distribution: You can freely use this code in your own applications, but
' you may not reproduce or publish this code on any web site, online service,
' or distribute as source on any media without express permission.
' Terms: Use at your own risk. Provided "as is" with no warranties.
' Use of CryptoSys API requires a licence for non-personal use.
' Contact: <https://di-mgt.com.au> <https://cryptosys.net>
'****************************************************************************
' This file last updated:
'   $Date: 2007-05-20 20:35:00 $
'   $Author: dai $
'****************************************************************************

' This code shows how you can use CryptoSys API to create and read MySecret
' data. This code is provided merely to DEMONSTRATE the principles involved.
' It is not meant as an example of production code.
' At the very minimum:
'   * Remove all the debugging statments
'   * Add proper error handling

' MySecret Reference: <http://di-mgt.com.au/mysecret.html#technical>

' This code requires the CryptoSys API library to be installed on your system
' and the `basCryptoSys.bas' module to be included in your project.
' Download CryptoSys API from <http://cryptosys.net/#api>
' Commercial use requires a licence: <http://cryptosys.net/purchase.html>

' *************************
' INTERNAL CONSTANTS WE USE
' *************************
Private Const BLOCK_LEN As Long = 8
Private Const FRAME_LEN As Long = 60
Private Const STRETCH_COUNT As Long = 1024
Private Const FRAME_BEGIN As String = "-----BEGIN MYSECRET-----"
Private Const FRAME_END As String = "-----END MYSECRET-----"
Private Const FRAME_STUB As String = "-----BEGIN MYSECRET"

' ******
' TESTS
' ******
' To test a freshly-encrypted-and-so-different output, try this:
'   ? MySecret_Decrypt(Test_MySecret_Encrypt(), "password")

Public Function Test_MySecret_Encrypt() As String
    Dim strPlain As String
    Dim strPassword As String
    Dim strOutput As String

    ' INPUT PASSWORD
    strPassword = "password"
    ' INPUT PLAINTEXT
    strPlain = "KING RICHARD. A horse! a horse! my kingdom for a horse!" & vbCrLf & _
       "CATESBY. Withdraw, my lord! I'll help you to a horse." & vbCrLf & _
       "KING RICHARD. Slave, I have set my life upon a cast" & vbCrLf & _
       "And I Will stand the hazard of the die." & vbCrLf & _
       "I think there be six Richmonds in the field;" & vbCrLf & _
       "Five have I slain to-day instead of him." & vbCrLf & _
       "A horse! a horse! my kingdom for a horse!             Exeunt"
       
    ' Do the business
    strOutput = MySecret_Encrypt(strPlain, strPassword)
    Debug.Print strOutput
    
    ' Clear the password
    Call WIPE_String(strPassword, Len(strPassword))
    
    Test_MySecret_Encrypt = strOutput

End Function

Public Function Test_MySecret_Decrypt() As String
    Dim strInput As String
    Dim strPassword As String
    Dim strOutput As String
    
    ' INPUT PASSWORD
    strPassword = "password"
    ' INPUT MYSECRET-DATA
    strInput = "-----BEGIN MYSECRET-----" & vbCrLf & _
        "TVn8AEFK9uRT91snxkz5y2TguL39hcNxEjRctQzipRaagPLTe0tYQikxIPlQ" & vbCrLf & _
        "UPHGKDJVK3c9UTcNOqCa2eDmdJaUIJoAXITLeCdLMRfe+I0QYuBVDAqHpQwz" & vbCrLf & _
        "2LscsDWlNHiqbGYeP0IyYiv0tk7mzKwj9PSSiKK5xtdiXo29BJR2+JtiOQTc" & vbCrLf & _
        "QgZzURnAWIpc5/INeSJ/6rm4BZRU2Db/sMgdMLrNSIBeKEP+FKJ58/wAUems" & vbCrLf & _
        "2q03DMsIcs2Scp78JabqF6RbzYaHTDH2tV8fmAGVXnCTXKaor7dk1ZuWD0Ny" & vbCrLf & _
        "D0azfzNqGZm/hgp15HGDrXqkJdEq/XlMulOnxKyzqx0pJkYqNwxDHCDFE8MN" & vbCrLf & _
        "KOqyeUhqm+LOjq6I6iUhaLoMVAtIew==" & vbCrLf & _
        "-----END MYSECRET-----"
        
    ' Do the business
    strOutput = MySecret_Decrypt(strInput, strPassword)
    Debug.Print strOutput
    
    ' Clear the password
    Call WIPE_String(strPassword, Len(strPassword))
    
    Test_MySecret_Decrypt = strOutput
    
End Function

' ***********************
' MAIN EXPORTED FUNCTIONS
' ***********************
Public Function MySecret_Encrypt(strPlain As String, strPassword As String) As String
' INPUT:  plaintext string, password
' OUTPUT: string of MySecret v3 base64-encoded ciphertext (with framing and CR-LFs)

    Dim strOutput As String
    Dim abPlain() As Byte
    Dim nPlain As Long
    Dim abCompr() As Byte
    Dim nCompr As Long
    Dim abBlock() As Byte
    Dim nBlock As Long
    Dim abPad() As Byte
    Dim nPad As Long
    Dim abKey() As Byte
    Dim nKey As Long
    Dim abEncode() As Byte
    Dim nEncode As Long
    Dim abInitVec() As Byte
    Dim abNumber() As Byte
    Dim strBase64 As String
    Dim nCrc24 As Long
    Dim k As Long
    Dim i As Long
    Dim iOffset As Long
    Dim iCount As Long
    Dim nChars As Long
    Dim nRet As Long
 
    If Len(strPlain) = 0 Then
        Debug.Print "ERROR: nothing to encrypt!"
        Exit Function
    End If
    
    Debug.Print "PLAINTEXT: [" & strPlain & "]"

    ' CONVERT input string to a byte array
    abPlain = StrConv(strPlain, vbFromUnicode)
    nPlain = UBound(abPlain) - LBound(abPlain) + 1
    Debug.Print "Plaintext length = " & nPlain & " bytes"
    
    ' COMPUTE THE CRC-24 CHECKSUM of the original plaintext
    nCrc24 = CRC24_Bytes(abPlain)
    Debug.Print "CRC-24 = " & Hex(nCrc24)
    
    ' COMPRESS using ZLIB_Deflate function
    ' -- first get the compressed length
    nCompr = ZLIB_Deflate(vbNull, 0, abPlain(0), nPlain)
    If nCompr <= 0 Then
        Debug.Print "ERROR: compression failed."
        GoTo Clean_Up
    End If
    Debug.Print "Compressed length = " & nCompr & " bytes"
    ' -- then do the compression
    ReDim abCompr(nCompr - 1)
    nCompr = ZLIB_Deflate(abCompr(0), nCompr, abPlain(0), nPlain)
    Debug.Print "Compressed data (hex)=" & cnvHexStrFromBytes(abCompr)
    
    ' CREATE A PADDING STRING OF LENGTH NPAD (actually a Byte array)
    '|<--------------NPAD--------------->|
    '|<---8--->|<----(8*k)---->|<-[1,8]->|
    '+---------+---------------+---------+
    '|  GUARD  |Random bytes...|  FINAL  |
    '+---------+---------------+---------+
    ' GUARD = 8 bytes of value NPAD
    ' FINAL = [1,8] bytes of value NPAD
    ' k = random number [0,7]
    ' Min(NPAD) = 8 + 8*0 + 1 = 9
    ' Max(NPAD) = 8 + 8*7 + 8 = 72
    
    ' Compute final number of odd bytes [1,8] to make length an exact multiple of 8
    nPad = BLOCK_LEN - (10 + nCompr + 3) Mod BLOCK_LEN
    ' -- pick a random number between 0 and 7
    k = RNG_Long(0, 7, "")
    Debug.Print "Random blocks = " & k
    ' -- increase size for extra blocks of 8
    nPad = nPad + (k + 1) * BLOCK_LEN
    Debug.Print "Padding string = " & nPad & " bytes = 0x" & Hex(nPad)
    ' Fill with random bytes
    ' (it's easier to fill the whole with random and then overwrite)
    ReDim abPad(nPad - 1)
    Call RNG_NonceData(abPad(0), nPad)
    ' Set value of bytes in guard and final blocks equal to NPAD
    For i = 0 To 7
        abPad(i) = CByte(nPad)
    Next
    For i = ((k + 1) * BLOCK_LEN) To nPad - 1
        abPad(i) = CByte(nPad)
    Next
    Debug.Print "Padding string (hex)=" & cnvHexStrFromBytes(abPad)
    
    ' COMPOSE the encryption block
    '|<------------------------nBlock--------------------------->|
    '|<--------10--------->|<------nCompr------>|<-3-->|<-nPad-->|
    '+-----+-------+-------+--------------------+------+---------+
    '|ZS(2)|CLEN(4)|ULEN(4)| Compressed data... |CRC(3)|PAD(9-72)|
    '+-----+-------+-------+--------------------+------+---------+
    nBlock = 10 + nCompr + 3 + nPad
    Debug.Print "Encryption block = " & nBlock & " bytes = " & nBlock / BLOCK_LEN & " blocks"
    ReDim abBlock(nBlock - 1)
    ' -- Two-byte signature 0x5A04
    abBlock(0) = &H5A   ' =Asc("Z")
    abBlock(1) = &H4    ' =0x04
    iOffset = 2
    ' -- convert CLEN and ULEN integers into 4-byte arrays in big-endian order
    ' -- and add to block
    abNumber = BytesFromLong(nCompr)
    For i = 0 To 3
        abBlock(iOffset) = abNumber(i)
        iOffset = iOffset + 1
    Next
    abNumber = BytesFromLong(nPlain)
    For i = 0 To 3
        abBlock(iOffset) = abNumber(i)
        iOffset = iOffset + 1
    Next
    ' -- add the compressed data
    For i = 0 To nCompr - 1
        abBlock(iOffset) = abCompr(i)
        iOffset = iOffset + 1
    Next
    ' -- convert the CRC-24 value into an array and add the last THREE bytes
    abNumber = BytesFromLong(nCrc24)
    For i = 1 To 3  ' NOTE: we only add three bytes here
        abBlock(iOffset) = abNumber(i)
        iOffset = iOffset + 1
    Next
    ' -- add the padding string
    For i = 0 To nPad - 1
        abBlock(iOffset) = abPad(i)
        iOffset = iOffset + 1
    Next
    Debug.Print "Encr block (before)=    " & cnvHexStrFromBytes(abBlock)
    
    ' GENERATE a random 8-byte initialization vector
    ReDim abInitVec(BLOCK_LEN - 1)
    Call RNG_NonceData(abInitVec(0), BLOCK_LEN)
    Debug.Print "IV (hex)=" & cnvHexStrFromBytes(abInitVec)
    
    ' CREATE the 128-bit key using stretching with the IV as a salt
    abKey = MakeStretchedKey(strPassword, abInitVec, BLOCK_LEN, STRETCH_COUNT)
    nKey = UBound(abKey) + 1
    Debug.Print "KEY (hex)=" & cnvHexStrFromBytes(abKey)
    
    ' ENCRYPT THE BLOCK using Blowfish in CBC mode using the key and IV
    nRet = BLF_BytesMode(abBlock(0), abBlock(0), nBlock, abKey(0), nKey, ENCRYPT, "CBC", abInitVec(0))
    Debug.Print "BLF_BytesMode returns " & nRet & " (expecting 0)"
    If nRet <> 0 Then
        Debug.Print "ERROR: encryption operation failed!"
        GoTo Clean_Up
    End If
    Debug.Print "Encr block (after) =    " & cnvHexStrFromBytes(abBlock)
    
    ' ADD THE MAIN HEADER to the ciphertext block
    ReDim abEncode(4 + BLOCK_LEN + nBlock - 1)
    ' -- 4-byte header
    abEncode(0) = &H4D  ' "M"
    abEncode(1) = &H59  ' "Y"
    abEncode(2) = &HFC
    abEncode(3) = &H0
    ' -- 8-byte IV
    iOffset = 4
    For i = 0 To BLOCK_LEN - 1
        abEncode(iOffset + i) = abInitVec(i)
    Next
    ' -- ciphertext block
    iOffset = 4 + BLOCK_LEN
    For i = 0 To nBlock - 1
        abEncode(iOffset + i) = abBlock(i)
    Next
    nEncode = 4 + BLOCK_LEN + nBlock
    Debug.Print "To encode (hex) ="
    Debug.Print "<-------HEADER---------><--ENCR BLOCK-->>"
    Debug.Print cnvHexStrFromBytes(abEncode)
    
    ' ENCODE TO BASE 64
    strBase64 = cnvB64StrFromBytes(abEncode)
    Call WIPE_Data(abEncode(0), nEncode)
    Debug.Print "Base64=" & strBase64
    
    ' ADD FRAMING AND LINE-BREAKS every 60 chars
    strOutput = FRAME_BEGIN & vbCrLf
    nChars = Len(strBase64)
    iOffset = 1
    Do While nChars > FRAME_LEN
        strOutput = strOutput & Mid$(strBase64, iOffset, FRAME_LEN) & vbCrLf
        nChars = nChars - FRAME_LEN
        iOffset = iOffset + FRAME_LEN
    Loop
    ' -- append final line, if any
    If nChars > 0 Then
        strOutput = strOutput & Mid$(strBase64, iOffset, nChars) & vbCrLf
    End If
    strOutput = strOutput & FRAME_END & vbCrLf
    
    ' OUTPUT the MySecret-formatted string
    MySecret_Encrypt = strOutput

Clean_Up:
    Call WIPE_Data(abPlain(0), nPlain)
    Call WIPE_Data(abCompr(0), nCompr)
    Call WIPE_Data(abPad(0), nPad)
    Call WIPE_Data(abBlock(0), nBlock)
    Call WIPE_Data(abKey(0), nKey)
    Call WIPE_Data(abEncode(0), nEncode)
    Call WIPE_String(strBase64, Len(strBase64))
    Call WIPE_String(strOutput, Len(strOutput))
    
End Function


Public Function MySecret_Decrypt(strInput As String, strPassword As String) As String
' INPUT: password, string of MySecret v3 base64-encoded ciphertext
' OUTPUT: decrypted plaintext string or empty string on error
    
    Dim strBase64 As String
    Dim nBeg As Long
    Dim nEnd As Long
    Dim i As Long
    Dim iOffset As Long
    Dim nRet As Long
    Dim abEncode() As Byte
    Dim nEncode As Long
    Dim abInitVec() As Byte
    Dim abKey() As Byte
    Dim nKey As Long
    Dim abBlock() As Byte
    Dim nBlock As Long
    Dim abCompr() As Byte
    Dim nCompr As Long
    Dim abPlain() As Byte
    Dim nPlain As Long
    Dim nPad As Long
    Dim nCrc24 As Long
    Dim nCrcChk As Long
    
    If Len(strInput) = 0 Then
        Debug.Print "ERROR: nothing to decrypt!"
        Exit Function
    End If
    
    ' Pre-set byte arrays in case we fail - see Clean_Up
    abEncode = StrConv("", vbFromUnicode)
    abKey = StrConv("", vbFromUnicode)
    abBlock = StrConv("", vbFromUnicode)
    abCompr = StrConv("", vbFromUnicode)
    abPlain = StrConv("", vbFromUnicode)
    
    Debug.Print "Input = " & Len(strInput) & " bytes"
    ' REMOVE FRAMING, get base64 data
    nBeg = InStr(1, strInput, FRAME_STUB)
    If nBeg <= 0 Then
        Debug.Print "ERROR: Not valid MySecret data!"
        Exit Function
    End If
    nBeg = nBeg + Len(FRAME_STUB)
    ' -- skip to start of base64 data (old-style headers may be "BEGIN MYSECRETxxx-----")
    nBeg = InStr(nBeg, strInput, "-")
    Do While nBeg > 0 And nBeg < Len(strInput) And Mid(strInput, nBeg, 1) = "-"
        nBeg = nBeg + 1
    Loop
    If nBeg >= Len(strInput) Then
        Debug.Print "ERROR: Not valid MySecret data!"
        Exit Function
    End If
    nEnd = InStr(nBeg, strInput, FRAME_END)
    If nEnd <= 0 Or nEnd <= nBeg Then
        Debug.Print "ERROR: Not valid MySecret data!"
        Exit Function
    End If
    strBase64 = Mid$(strInput, nBeg, nEnd - nBeg)
    Debug.Print "Base64=" & strBase64
    
    ' DECODE BASE64 to byte array (any non-base-64 chars, including CR-LFs, are ignored)
    abEncode = cnvBytesFromB64Str(strBase64)
    nEncode = UBound(abEncode) + 1
    Debug.Print "Encoded data = " & nEncode & " bytes"
    Debug.Print cnvHexStrFromBytes(abEncode)
    
    '+------+-------+-----------------------------------------------------------+
    '|SIG(4)| IV(8) | Ciphertext...                                             |
    '+------+-------+-----------------------------------------------------------+
    
    ' We expect 4 signature bytes 0x4D59FC00 and at least 15 bytes of data
    If nEncode < 15 Or abEncode(0) <> &H4D Or abEncode(1) <> &H59 Or abEncode(3) <> &H0 Then
        Debug.Print "ERROR: Not MySecret data."
        GoTo Clean_Up
    End If
    ' -- the third byte gives us the version: 0xFC=v3, 0xFD=v2
    If abEncode(2) <> &HFC Then
        Debug.Print "ERROR: Sorry, we only decrypt version 3."
        GoTo Clean_Up
    End If
    Debug.Print "Found MYSECRET signature for version 3"
    
    ' Copy the 8-byte IV
    ReDim abInitVec(BLOCK_LEN - 1)
    iOffset = 4
    For i = 0 To BLOCK_LEN - 1
        abInitVec(i) = abEncode(iOffset + i)
    Next
    Debug.Print "IV=" & cnvHexStrFromBytes(abInitVec)
    
    ' RE-CREATE THE KEY
    ' CREATE the 128-bit key using stretching with the IV as a salt
    abKey = MakeStretchedKey(strPassword, abInitVec, BLOCK_LEN, STRETCH_COUNT)
    Debug.Print "KEY=" & cnvHexStrFromBytes(abKey)
    nKey = UBound(abKey) + 1
    
    ' Copy the decryption block
    iOffset = BLOCK_LEN + 4
    nBlock = nEncode - iOffset
    ReDim abBlock(nBlock - 1)
    For i = 0 To nBlock - 1
        abBlock(i) = abEncode(iOffset + i)
    Next
    Debug.Print "Encr block (before)=" & cnvHexStrFromBytes(abBlock)
    
    ' DECRYPT the entire block
    nRet = BLF_BytesMode(abBlock(0), abBlock(0), nBlock, abKey(0), nKey, DECRYPT, "CBC", abInitVec(0))
    Debug.Print "BLF_BytesMode returns " & nRet & " (expecting 0)"
    If nRet <> 0 Then
        Debug.Print "ERROR: Decryption error."
        GoTo Clean_Up
    End If
    Debug.Print "Encr block (after) =" & cnvHexStrFromBytes(abBlock)
    
    ' PARSE the v3 block
    '|<------------------------nBlock--------------------------->|
    '|<--------10--------->|<------nCompr------>|<--3->|<-nPad-->|
    '+-----+-------+-------+--------------------+------+---------+
    '|ZS(2)|CLEN(4)|ULEN(4)| Compressed data... |CRC(3)|PAD(9-72)|
    '+-----+-------+-------+--------------------+------+---------+
    
    ' EXAMINE the decrypted block for 2-byte signature
    If abBlock(0) <> &H5A Or abBlock(1) <> &H4 Then
        Debug.Print "ERROR: Decryption error."
        GoTo Clean_Up
    End If
    
    ' EXTRACT lengths from big-endian-encoded values
    iOffset = 2
    nCompr = uwJoin(abBlock(iOffset + 0), abBlock(iOffset + 1), abBlock(iOffset + 2), abBlock(iOffset + 3))
    iOffset = 6
    nPlain = uwJoin(abBlock(iOffset + 0), abBlock(iOffset + 1), abBlock(iOffset + 2), abBlock(iOffset + 3))
    Debug.Print "Compressed length=" & nCompr & ", Uncompressed length=" & nPlain
    
    ' CHECK for reasonableness
    If nCompr < 0 Or nPlain < 0 Or nCompr > nBlock Then
        Debug.Print "ERROR: Decryption error."
        GoTo Clean_Up
    End If
    
    ' EXTRACT length of padding string: length is given by the very last byte.
    nPad = CLng(abBlock(nBlock - 1))
    Debug.Print "Padding string is " & nPad & " bytes"
    
    ' CONFIRM all lengths now match
    If nBlock <> 10 + nCompr + 3 + nPad Then
        Debug.Print "ERROR: Decryption error."
        GoTo Clean_Up
    End If
    
    ' CHECK GUARD BYTES: we expect 8 bytes of value NPAD at the start of the padding string
    iOffset = nBlock - nPad
    For i = 0 To 7
        If abBlock(iOffset + i) <> CByte(nPad) Then
            Debug.Print "ERROR: Decryption error."
            GoTo Clean_Up
        End If
    Next
    
    ' EXTRACT the 3-byte CRC-24 value immediately before
    iOffset = nBlock - nPad - 3
    ' -- note this is only 3-bytes long with a zero most-significant byte
    nCrcChk = uwJoin(&H0, abBlock(iOffset + 0), abBlock(iOffset + 1), abBlock(iOffset + 2))
    Debug.Print "CRC-24 value found = " & Hex(nCrcChk)
    
    ' DECOMPRESS the plaintext (careful to use exact lengths here)
    ReDim abCompr(nCompr - 1)
    ReDim abPlain(nPlain - 1)
    iOffset = 10
    For i = 0 To nCompr - 1
        abCompr(i) = abBlock(iOffset + i)
    Next
    nRet = ZLIB_Inflate(abPlain(0), nPlain, abCompr(0), nCompr)
    Debug.Print "ZLIB_Inflate returns " & nRet & " (expecting " & nPlain & ")"
    If nRet < 0 Then
        Debug.Print "ERROR: Decryption error (inflate failed)."
        GoTo Clean_Up
    End If
    Debug.Print "Decompressed data (hex)=" & cnvHexStrFromBytes(abPlain)
    
    ' COMPUTE the CRC-24 checksum for the recovered plaintext
    nCrc24 = CRC24_Bytes(abPlain)
    Debug.Print "CRC-24 = " & Hex(nCrc24)
    
    ' VERIFY that the checksums match
    If nCrc24 <> nCrcChk Then
        Debug.Print "ERROR: Decryption error (CRC checksum failed)."
        GoTo Clean_Up
    End If
    
    ' DECODE the byte array to an output string
    MySecret_Decrypt = StrConv(abPlain, vbUnicode)
        
Clean_Up:
    If UBound(abEncode) > 0 Then Call WIPE_Data(abEncode(0), nEncode)
    If UBound(abKey) > 0 Then Call WIPE_Data(abKey(0), nKey)
    If UBound(abBlock) > 0 Then Call WIPE_Data(abBlock(0), nBlock)
    If UBound(abCompr) > 0 Then Call WIPE_Data(abCompr(0), nCompr)
    If UBound(abPlain) > 0 Then Call WIPE_Data(abPlain(0), nPlain)
    
End Function

' ******************
' INTERNAL FUNCTIONS
' ******************

Private Function MakeStretchedKey(strPassword As String, abSalt() As Byte, nSalt As Long, _
    nStretchCount As Long) As Variant
' Returns a 128-bit/16-byte key in a byte array passed back as a VARIANT
    Dim abPassword() As Byte
    Dim abTemp() As Byte
    Dim abDigest() As Byte
    Dim nPassword As Long
    Dim nTemp As Long
    Dim nDigest As Long
    Dim i As Long
    Dim iCount As Long
    Dim iOffset As Long
    Dim abKey() As Byte
    Dim nKey As Long
    Dim nRet As Long
    
    ' INPUT:  password (p) and salt (s).
    ' OUTPUT: 16-byte key
        ' Set X(1) = MD5 (p || s)
        ' For i = 2 to 1024, set X(i) = MD5 (X(i-1) || p || s)
        ' Set the key as the final value of X(i).
        ' where || denotes ordered concatenation of two strings.
    ' COMMENT: this method is messy to do in VB. In retrospect, the PBKDF1 method from PKCS#5
    ' would have been easier and just as secure, but we used this variant (from Schneier,
    ' Applied Cryptography, p??) in Version 1 and so we stick with it.
    
    nKey = 16
    nDigest = API_MAX_MD5_BYTES
    ReDim abDigest(nDigest - 1)
    abPassword = StrConv(strPassword, vbFromUnicode)
    nPassword = UBound(abPassword) - LBound(abPassword) + 1
    ' Set X(1) = MD5 (p || s)
    nTemp = nPassword + nSalt
    ReDim abTemp(nTemp - 1)
    iOffset = 0
    For i = 0 To nPassword - 1
        abTemp(iOffset + i) = abPassword(i)
    Next
    iOffset = nPassword
    For i = 0 To nSalt - 1
        abTemp(iOffset + i) = abSalt(i)
    Next
    nRet = MD5_BytesHash(abDigest(0), abTemp(0), nTemp)
    
    ' For i = 2 to 1024, set X(i) = MD5 (X(i-1) || p || s)
    nTemp = nDigest + nPassword + nSalt
    ReDim abTemp(nTemp - 1)
    For iCount = 2 To nStretchCount
        iOffset = 0
        For i = 0 To nDigest - 1
            abTemp(iOffset + i) = abDigest(i)
        Next
        iOffset = iOffset + nDigest
        For i = 0 To nPassword - 1
            abTemp(iOffset + i) = abPassword(i)
        Next
        iOffset = iOffset + nPassword
        For i = 0 To nSalt - 1
            abTemp(iOffset + i) = abSalt(i)
        Next
        nRet = MD5_BytesHash(abDigest(0), abTemp(0), nTemp)
    Next iCount
    
    ' Set the key as the final value of X(i).
    If nKey > nDigest Then nKey = nDigest
    ReDim abKey(nKey - 1)
    For i = 0 To nKey - 1
        abKey(i) = abDigest(i)
    Next
    
    ' Return key as a Byte array in a Variant
    MakeStretchedKey = abKey
    
    ' Clean up
    Call WIPE_Data(abTemp(0), nTemp)
    Call WIPE_Data(abDigest(0), nDigest)
    Call WIPE_Data(abPassword(0), nPassword)
    Call WIPE_Data(abKey(0), nKey)

End Function

' ************************************************************************
' FUNCTIONS TO CONVERT BETWEEN 32-BIT INTEGERS AND BIG-ENDIAN BYTES ARRAYS
' ************************************************************************
Private Function BytesFromLong(ByVal w As Long) As Variant
' Returns a byte array but as a VARIANT type
    Dim abBytes() As Byte
    ReDim abBytes(3)
    Call uwSplit(w, abBytes(0), abBytes(1), abBytes(2), abBytes(3))
    BytesFromLong = abBytes
End Function

Private Function uwJoin(a As Byte, b As Byte, c As Byte, d As Byte) As Long
' Join 4 x 8-bit bytes into one 32-bit word a.b.c.d
    uwJoin = ((a And &H7F) * &H1000000) Or (b * &H10000) Or (CLng(c) * &H100) Or d
    If a And &H80 Then
        uwJoin = uwJoin Or &H80000000
    End If
End Function

Private Sub uwSplit(ByVal w As Long, a As Byte, b As Byte, c As Byte, d As Byte)
' Split 32-bit word w into 4 x 8-bit bytes
    a = CByte(((w And &HFF000000) \ &H1000000) And &HFF)
    b = CByte(((w And &HFF0000) \ &H10000) And &HFF)
    c = CByte(((w And &HFF00) \ &H100) And &HFF)
    d = CByte((w And &HFF) And &HFF)
End Sub

' **************************************************
' FUNCTIONS TO CARRY OUT CRC-24 CHECKSUM COMPUTATION
' **************************************************
' basCRC24: Calculates CRC-24 checksum for a given message string
' Version 1. Published 4 June 2003.
'************************* COPYRIGHT NOTICE*************************
' This code was originally written in Visual Basic by David Ireland
' and is copyright (c) 2003-6 D.I. Management Services Pty Limited,
' all rights reserved.
' For more details, see <http://di-mgt.com.au/src/basCRC24.txt>
'*******************************************************************
Public Function CRC24_Bytes(abMessage() As Byte) As Long
    Const CRC24_INIT As Long = &HB704CE
    Const CRC24_POLY As Long = &H1864CFB
    Dim i As Long
    Dim j As Integer
    Dim ulCRC As Long
    
    ulCRC = CRC24_INIT
    For i = LBound(abMessage) To UBound(abMessage)
        ulCRC = ulCRC Xor ulShiftLeftBy16(abMessage(i))
        For j = 0 To 7
            ulCRC = ulShiftLeftByOne(ulCRC)
            If (ulCRC And &H1000000) <> 0 Then
                ulCRC = ulCRC Xor CRC24_POLY
            End If
        Next
    Next
    
    CRC24_Bytes = ulCRC And &HFFFFFF

End Function

Public Function CRC24_String(sMessage As String) As Long

    Dim abMessage() As Byte
    
    ' Use proper VB function to get an array of bytes
    ' thus avoiding problems with Unicode/ANSI/DBCS character sets
    abMessage = StrConv(sMessage, vbFromUnicode)
    CRC24_String = CRC24_Bytes(abMessage)
    
End Function

Private Function ulShiftLeftBy16(ByVal wordX As Long) As Long
' Shift 32-bit long value to left by 16 bits
' i.e. VB equivalent of "wordX << 16" in C
' Avoiding problem with sign bit
' Copyright (C) 2000-25 DI Management Services Pty Ltd
    ulShiftLeftBy16 = (wordX And &H7FFF&) * &H10000
    If (wordX And &H8000&) <> 0 Then
        ulShiftLeftBy16 = ulShiftLeftBy16 Or &H80000000
    End If
End Function

Private Function ulShiftLeftByOne(ByVal wordX As Long) As Long
' Shift 32-bit long value to left by 1 bits
' i.e. VB equivalent of "wordX << 1" in C
' Avoiding problem with sign bit
' Copyright (C) 2000-25 DI Management Services Pty Ltd
    ulShiftLeftByOne = (wordX And &H7FFFFFFF) * &H2
    If (wordX And &H8000000) <> 0 Then
        ulShiftLeftByOne = ulShiftLeftByOne Or &H80000000
    End If
End Function