Attribute VB_Name = "Module1"
Dim Key1 As Long
Dim EBP_C As Long
Dim EBP_8 As Long
Dim EBP_4 As Long
Dim Key2 As Long
Dim Key3 As Long
Dim DecryptKey As Byte
Global Const Encrypted = "4B1FEC793DACE5A9BC0BBFF6983BDF8AC083ABC53F04B3B4252AA9E8A81F99EFED4BB30FA23BD4"
Global Const Key = "abcdefghijkl"
Global Const Decrypted = "N9IK-V9A6-79DL-Q926-46EC-8182-8299-2927"

Private Sub InitCrypt(Key As String)
    Do Until Len(Key) >= 12
        Key = Key & Key
    Loop
    Key = Left(Key, 12)
    
    'Combine first 4 bytes of key, by converting the ascii value of char to hex and concatenating
    temp = temp & Hex(Asc(Mid(Key, 1, 1)))
    temp = temp & Hex(Asc(Mid(Key, 2, 1)))
    temp = temp & Hex(Asc(Mid(Key, 3, 1)))
    temp = temp & Hex(Asc(Mid(Key, 4, 1)))
    
    Key1 = Val("&H" & temp)
    temp = ""
    'Combine middle 4 bytes of key, by converting the ascii value of char to hex and concatenating
    temp = temp & Hex(Asc(Mid(Key, 5, 1)))
    temp = temp & Hex(Asc(Mid(Key, 6, 1)))
    temp = temp & Hex(Asc(Mid(Key, 7, 1)))
    temp = temp & Hex(Asc(Mid(Key, 8, 1)))
    
    Key2 = Val("&H" & temp)
    temp = ""
    'Combine last 4 bytes of key, by converting the ascii value of char to hex and concatenating
    temp = temp & Hex(Asc(Mid(Key, 9, 1)))
    temp = temp & Hex(Asc(Mid(Key, 10, 1)))
    temp = temp & Hex(Asc(Mid(Key, 11, 1)))
    temp = temp & Hex(Asc(Mid(Key, 12, 1)))
    
    Key3 = Val("&H" & temp)
    DecryptKey = 0
End Sub

Public Function CryptString(EncryptedString As String, Key As String, Optional EncryptedIsHexString As Boolean = True) As String
    Dim Result As String
    Dim CurrentByte As Byte
    InitCrypt (Key)
If EncryptedIsHexString Then
    For X = 0 To Len(EncryptedString) / 2
        temp = Mid(EncryptedString, (X * 2) + 1, 2)
        CurrentByte = Val("&H" & temp)
        Result = Result & CryptByte(CurrentByte)
    Next X
    Result = Left(Result, Len(Result) - 1)
Else
    For X = 1 To Len(EncryptedString)
        CurrentByte = Asc(Mid(EncryptedString, X, 1))
        newByte = CryptByte(CurrentByte)
        Result = Result & IIf(Len(Hex(Asc(newByte))) = 2, Hex(Asc(newByte)), "0" & Hex(Asc(newByte)))
    Next X
End If
CryptString = Result
End Function

Private Function CryptByte(theByte As Byte) As String
    EBP_4 = 0
    EBP_C = EvenOdd(Key2)
    EBP_8 = EvenOdd(Key3)
    
    For X = 1 To 8
        If EvenOdd(Key1) = 0 Then
            Key1 = Key1 / 2
            Key1 = Key1 And &H7FFFFFFF
            If EvenOdd(Key3) = 0 Then
                Key3 = ShiftRight(Key3, 1)
                Key3 = Key3 And &HFFFFFFF
                EBP_8 = 0
                GoTo NextLoop
            Else
                Key3 = Key3 Xor &H10000002
                Key3 = ShiftRight(Key3, 1)
                Key3 = Key3 Or &HF0000000
                EBP_8 = 1
                GoTo NextLoop
            End If
        Else
            Key1 = Key1 Xor &H80000000
            Key1 = Key1 Xor &H62
            Key1 = ShiftRight(Key1, 1)
            Key1 = Key1 Or &H80000000
            If EvenOdd(Key2) = 0 Then
                Key2 = ShiftRight(Key2, 1)
                Key2 = Key2 And &H3FFFFFFF
                EBP_C = 0
                GoTo NextLoop
            Else
                Key2 = Key2 Xor &H40000020
                Key2 = ShiftRight(Key2, 1)
                Key2 = Key2 Or &HC0000000
                EBP_C = 1
                GoTo NextLoop
            End If
        End If

NextLoop:
        EBP_4 = EBP_4 * 2
        EBP_4 = EBP_4 And 65535
        temp = EBP_C Xor EBP_8
        EBP_4 = EBP_4 Or temp
    Next X
    CryptByte = Chr(theByte Xor EBP_4)
End Function


Private Function EvenOdd(theValue As Long) As Long
    EvenOdd = Abs(theValue) Mod 2
End Function

Private Function ShiftRight(ByVal Value As Long, ByVal times As Long) As Long
    ' we need to create a mask of 1's corresponding to the
    ' digits in VALUE that will be retained in the result
    Dim mask As Long, signBit As Long
    
    ' return zero if too many times
    If times >= 32 Then Exit Function
    ' return the value if zero times
    If times = 0 Then ShiftRight = Value: Exit Function
    
    ' evaluate the sign bit in advance
    signBit = (Value < 0) And Power2(31 - times)
    ' create a mask with 1's for the digits that will be preserved
    If times < 31 Then
        ' if times=31 then the mask is zero
        mask = Not (Power2(times) - 1)
    End If
    ' clear all the digits that will be discarded, and
    ' also clear the sign bit
    Value = (Value And &H7FFFFFFF) And mask
    ' do the shift, without any problem, and add the sign bit
    ShiftRight = (Value \ Power2(times)) Or signBit
End Function

Private Function Power2(ByVal exponent As Long) As Long
    Static res(0 To 31) As Long
    Dim i As Long
    
    ' rule out errors
    If exponent < 0 Or exponent > 31 Then Err.Raise 5
    
    ' initialize the array at the first call
    If res(0) = 0 Then
        res(0) = 1
        For i = 1 To 30
            res(i) = res(i - 1) * 2
        Next
        ' this is a special case
        res(31) = &H80000000
    End If
    
    ' return the result
    Power2 = res(exponent)
        
End Function