Belajar VBA

Video Tutorial

Home VBA Lanjutan VBA Cryptography

VBA Cryptography

Updated on December 13, 2023 . 18 min read

Dalam era digital yang terus berkembang, perlindungan terhadap informasi menjadi semakin penting.

Bagaimana kita mengelola, mengirim, dan menyimpan data sangatlah vital, terutama ketika menghadapi ancaman keamanan cyber yang semakin kompleks.

Di balik upaya melindungi informasi sensitif ini, terdapat serangkaian teknik kunci dalam dunia kriptografi yang memainkan peran penting.

Diantaranya seperti Encoding, Enkripsi dan Hashing.

Dalam materi kali saya ingin mengajakmu untuk memahami esensi dari ketiga teknik ini serta peran masing-masing dalam menjaga keamanan informasi.

Mungkin terlihat sama, namun Encoding, Enkripsi, dan Hashing memiliki fungsi yang berbeda dan memegang peran khusus dalam perlindungan data.

Encoding

Encoding adalah proses mengonversi data dari satu bentuk ke bentuk lain,

seringkali untuk tujuan transfer data antar sistem yang berbeda atau penyimpanan data.

Encoding tidak mengubah struktur data secara fundamental dan dapat di-reverse (didekode) dengan mudah jika aturan encoding diketahui.

Contoh encoding misalnya Base64, UTF-8, dan ASCII.

Dalam VBA Encoding Base64 bisa dibuat seperti dibawah ini.

Encoding Base64

Function EncodeBase64(text As String) As String
  Dim arrData() As Byte
  arrData = StrConv(text, vbFromUnicode)

  Dim objXML As Object
  Dim objNode As Object

  Set objXML = CreateObject("MSXML2.DOMDocument")
  
  Set objNode = objXML.createElement("b64")

  objNode.DataType = "bin.base64"
  objNode.nodeTypedValue = arrData
  EncodeBase64 = Replace(objNode.text, vbLf, "")

  Set objNode = Nothing
  Set objXML = Nothing
End Function

Text yang dihasilkan oleh EncodeBase64 ini misalnya kita akan encoding kata “Belajar di vba.co.id” hasilnya bisa dilihat dibawah ini

EncodeBase64("belajar di vba.co.id")

hasil : YmVsYWphciBkaSB2YmEuY28uaWQ=

Enkripsi

Enkripsi adalah proses mengubah informasi atau pesan menjadi format yang tidak dapat dibaca atau dimengerti kecuali oleh pihak yang memiliki kunci dekripsi yang sesuai.

Tujuan utama enkripsi adalah untuk melindungi kerahasiaan data.

Enkripsi dapat berupa kriptografi simetris (dengan kunci yang sama untuk enkripsi dan dekripsi) atau asimetris (dengan sepasang kunci publik dan privat).

Untuk contoh Enkripsi misalnya : Caesar-Chipher , AES

Caesar-Chipher

Public Function CaesarCipher(ByVal TextToEncrypt As String, ByVal CaesarShift As Long) As String

    Dim OutputText As String
    TextToEncrypt = UCase(TextToEncrypt)

    If CaesarShift > 26 Then
        CaesarShift = CaesarShift Mod 26
    End If

    If CaesarShift = 0 Then
        OutputText = TextToEncrypt
    ElseIf CaesarShift > 0 Then
        OutputText = ShiftRight(TextToEncrypt, CaesarShift)
    Else
        CaesarShift = Abs(CaesarShift)
        OutputText = ShiftLeft(TextToEncrypt, CaesarShift)
    End If

    CaesarCipher = OutputText
End Function

Private Function ShiftLeft(ByVal ShiftString As String, ByVal ShiftQuantity As Long) As String

    Dim TextLength As Long
    TextLength = Len(ShiftString)

    Dim CipherText As String
    Dim CharacterCode As Long
    Dim AsciiIndex As Long
    Dim AsciiIdentifier() As Long
    ReDim AsciiIdentifier(1 To TextLength)

    For AsciiIndex = 1 To TextLength
        CharacterCode = Asc(Mid(ShiftString, AsciiIndex, 1))
        If CharacterCode = 32 Then GoTo Spaces
        If CharacterCode - ShiftQuantity < 65 Then
            CharacterCode = CharacterCode + 26 - ShiftQuantity
        Else: CharacterCode = CharacterCode - ShiftQuantity
        End If
Spaces:
        AsciiIdentifier(AsciiIndex) = CharacterCode
    Next

        For AsciiIndex = 1 To TextLength
            CipherText = CipherText & Chr(AsciiIdentifier(AsciiIndex))
        Next
    ShiftLeft = CipherText
End Function

Private Function ShiftRight(ByVal ShiftString As String, ByVal ShiftQuantity As Long) As String

    Dim TextLength As Long
    TextLength = Len(ShiftString)

    Dim CipherText As String
    Dim CharacterCode As Long
    Dim AsciiIndex As Long
    Dim AsciiIdentifier() As Long
    ReDim AsciiIdentifier(1 To TextLength)

    For AsciiIndex = 1 To TextLength
        CharacterCode = Asc(Mid(ShiftString, AsciiIndex, 1))
        If CharacterCode + ShiftQuantity > 90 Then
            CharacterCode = CharacterCode - 26 + ShiftQuantity
        ElseIf CharacterCode = 32 Then GoTo Spaces
        Else:  CharacterCode = CharacterCode + ShiftQuantity
        End If
Spaces:
        AsciiIdentifier(AsciiIndex) = CharacterCode
    Next

        For AsciiIndex = 1 To TextLength
            CipherText = CipherText & Chr(AsciiIdentifier(AsciiIndex))
        Next
    ShiftRight = CipherText
End Function

Hasil text yang dihasilkan oleh Enkripsi ini adalah

CaesarCipher("Saya belajar VBA",6)

hasil : YGEG HKRGPGX BHG

Sedangkan untuk membaliknya ganti 6 dengan -6

CaesarCipher("YGEG HKRGPGX BHG",-6)

Hasil : SAYA BELAJAR VBA

AES-128 CBC (Advanced Encryption Standard)

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://learn.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
    'Allowed algorithms:  https://learn.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

Untuk menggunakan Enkripsi AES ini bisa dilihat hasilnya dibawah ini

EncryptString("Belajar di VBA.co.id","Key123ABC")

hasil : Aqd4JMgNuPulOvmqxDCvfY9NAysl5UcBAkYW2LMJ0VUqMsSuT4baKbBR5UEfcXVn2RQyGC3qDTrld9Q69q7Ps+s/zso+NiYX4sLWmTmDASTyFdmlF6l+t8sxArcJKBK2

Sedangkan untuk melakukan Descript gunakan fungsi DecryptString

DecryptString("Aqd4JMgNuPulOvmqxDCvfY9NAysl5UcBAkYW2LMJ0VUqMsSuT4baKbBR5UEfcXVn2RQyGC3qDTrld9Q69q7Ps+s/zso+NiYX4sLWmTmDASTyFdmlF6l+t8sxArcJKBK2","Key123ABC")

Hasil : Belajar di VBA.co.id

Hashing

Hashing adalah proses mengonversi data menjadi nilai hash yang tetap panjang meskipun ukuran data input berubah.

Misalnya ketika melakukan hash pada kata “andi” dan “saya belajar VBA di vba.co.id” hasil hash dari dua contoh ini akan sama panjang hasil hash nya.

Fungsi hash bersifat satu arah.

artinya hash tidak dapat di-dekripsi untuk mendapatkan data asli dari nilai hash.

Tujuan utama hashing adalah untuk memverifikasi integritas data dan digunakan secara luas dalam pengamanan data, seperti dalam penyimpanan password atau verifikasi integritas file.

Untuk Contoh Hashing misalnya ada MD5 , SHA1, SHA256 , SHA385 , SHA512

Berikut ini adalah contoh Script VBA untuk membuat hashing.

Setiap hashing yang akan contohkan dibawah ini akan membutuhkan 1 fungsi yaitu ConvToHexString.

Private Function ConvToHexString(vIn As Variant) As Variant
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
End Function

Sehinga Script ConvToHexString ini harus selalu ada jika ingin menggunakan salah satu hashing dibawah ini.

System.Security.Cryptography Membutuhkan .NET Framework 3.5
vba.co.id

MD5 (Message Digest Algorithm 5)

Public Function MD5(ByVal sIn As String, Optional bB64 As Boolean = 0) As String
    Dim oT As Object, oMD5 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
        
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
 
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oMD5.ComputeHash_2((TextToHash))
 
    MD5 = ConvToHexString(bytes)
        
    Set oT = Nothing
    Set oMD5 = Nothing
End Function

Hasil hashing dari belajar di vba.co.id bisa dilihat hasilnya dibawah ini

Md5("Belajar di VBA.co.id")

Hasil : fbf1091baa314387b4dd40e30f36a55e

SHA-1 (Secure Hash Algorithm)

Public Function SHA1(sIn As String, Optional bB64 As Boolean = 0) As String
    Dim oT As Object, oSHA1 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
            
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA1 = CreateObject("System.Security.Cryptography.SHA1Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA1.ComputeHash_2((TextToHash))
        
    SHA1 = ConvToHexString(bytes)
            
    Set oT = Nothing
    Set oSHA1 = Nothing
    
End Function

SHA1("Belajar di VBA.co.id")

hasil : 2f3b8f963770ca96dcd96d5a28fc67c95ad4682e

SHA-256 (Secure Hash Algorithm)

Public Function SHA256(sIn As String, Optional bB64 As Boolean = 0) As String
    Dim oT As Object, oSHA256 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA256.ComputeHash_2((TextToHash))
    
    SHA256 = ConvToHexString(bytes)
    
    Set oT = Nothing
    Set oSHA256 = Nothing
End Function

SHA256("Belajar di VBA.co.id")

hasil : d94dba3a20ccd3ad019db70944fd0efc6b9352aff15682255a2885caf782047c

SHA-384 (Secure Hash Algorithm)

Public Function SHA384(sIn As String, Optional bB64 As Boolean = 0) As String
    Dim oT As Object, oSHA384 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA384 = CreateObject("System.Security.Cryptography.SHA384Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA384.ComputeHash_2((TextToHash))
    
    SHA384 = ConvToHexString(bytes)

    Set oT = Nothing
    Set oSHA384 = Nothing
    
End Function

SHA384("Belajar di VBA.co.id")

Hasil : b6a8176fbc172fd3c3157e7bd1707e12d7d97520c2fa19c1bb2d61bf29b6280d696bebf3478213b9b770b4825c48a400

SHA-512 (Secure Hash Algorithm)

Public Function SHA512(sIn As String, Optional bB64 As Boolean = 0) As String
    Dim oT As Object, oSHA512 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA512 = CreateObject("System.Security.Cryptography.SHA512Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA512.ComputeHash_2((TextToHash))
    
    SHA512 = ConvToHexString(bytes)
    
    Set oT = Nothing
    Set oSHA512 = Nothing
    
End Function

SHA512("Belajar di VBA.co.id")

hasil : f9f8423e7ba61d32f034ad367f2a1573accdcfc40246898628f708871cb54db64121a1472c9a3c6eff099e780cf001f4d3c6562da8a21fafd6e9786ad0847216

Previous: OLE Object Next: VBA Device Serial Number

VBA Lanjutan

15 Topics

Tutorial Lainnya