Attribute VB_Name = "BinaryEncryptor"
Public Function DecimalToBinary(ByVal eByte As Byte) As String
    Dim TempBin As Integer
    Dim Success As String
    If eByte = 0 Then
        Success = "0"
    Else
        Do While eByte <> 1
            TempBin = eByte Mod 2
            eByte = Int(eByte / 2)
            Success = TempBin & Success
        Loop
        Success = 1 & Success
    End If
    If Len(Success) < 8 Then
        Dim Cnt As Integer
        For Cnt = 1 To 8 - Len(Success)
            Success = 0 & Success
        Next Cnt
    End If
    DecimalToBinary = Success
End Function

Public Function BinaryToDecimal(ByVal eBinary As String) As Byte
    Dim TempByte As Long
    Dim TempSuccess As Long
    Dim Success As Long
    Dim Cnt As Integer
    eBinary = Trim(eBinary)
    eBinary = Str(Val(eBinary))
    eBinary = InvertString(eBinary)
    If Val(eBinary) <= 0 Then
        BinaryToDecimal = 0
        Exit Function
    End If
    For Cnt = 0 To Len(eBinary)
        TempByte = Val(Mid(eBinary, Cnt + 1, 1))
        TempSuccess = 2 ^ Cnt * TempByte
        Success = Success + TempSuccess
    Next Cnt
    BinaryToDecimal = Success
End Function

Public Function BinaryToHexaDecimal(ByVal eBinary As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualBin As String
    Dim TempDec As Integer
    Dim TempHex As String
    Dim Cnt As Long
    TextLen = Len(eBinary)
    If TextLen <= 0 Then Exit Function
    For Cnt = 1 To TextLen - 1 Step 4
        ActualBin = Mid(eBinary, Cnt, 4)
        TempDec = BinaryToDecimal(ActualBin)
        If TempDec >= 10 Then
            TempHex = Chr(TempDec + 55)
        Else
            TempHex = TempDec
        End If
        Success = Success & TempHex
    Next Cnt
    BinaryToHexaDecimal = Success
End Function

Public Function HexaDecimalToBinary(ByVal eHexaDecimal As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualHex As String
    Dim TempBin As String
    Dim TempDec As String
    Dim Cnt As Long
    TextLen = Len(eHexaDecimal)
    If TextLen <= 0 Then Exit Function
    For Cnt = 1 To 2
        ActualHex = Mid(eHexaDecimal, Cnt, 1)
        If Asc(ActualHex) >= 48 And Asc(ActualHex) <= 57 Then
            TempDec = Val(ActualHex)
            TempBin = Right(DecimalToBinary(TempDec), 4)
        Else
            TempDec = Asc(ActualHex) - 55
            TempBin = Right(DecimalToBinary(TempDec), 4)
        End If
        Success = Success & TempBin
    Next Cnt
    HexaDecimalToBinary = Success
End Function

Public Function DecimalToHexaDecimal(ByVal eByte As Byte) As String
    Dim Success As String
    Success = DecimalToBinary(eByte)
    Success = BinaryToHexaDecimal(Success)
    DecimalToHexaDecimal = Success
End Function

Public Function HexaDecimalToDecimal(ByVal eHexaDecimal As String) As Byte
    Dim Success As String
    Dim RealSuccess As Byte
    Success = HexaDecimalToBinary(eHexaDecimal)
    RealSuccess = BinaryToDecimal(Success)
    HexaDecimalToDecimal = RealSuccess
End Function

Public Function BoundBinary(ByVal eByte1 As Byte, ByVal eByte2 As Byte) As String
    Dim Success As String
    Dim StrBin1(1 To 4) As String
    Dim StrBin2(1 To 4) As String
    Dim TempBin1, TempBin2 As String
    Dim TempDec1, TempDec2 As Byte
    Dim HelpTempBin1, LastTempBin1 As String
    Dim Cnt, UCnt As Long
    TempBin1 = DecimalToBinary(eByte1)
    TempBin2 = DecimalToBinary(eByte2)
    Cnt = 1
    UCnt = 1
    Do
        StrBin1(UCnt) = Mid(TempBin1, Cnt, 2)
        StrBin2(UCnt) = Mid(TempBin2, Cnt, 2)
        Cnt = Cnt + 2
        UCnt = UCnt + 1
    Loop While UCnt <= 4
    Dim TempVal1, TempVal2, TempVal3, TempVal4 As String
    TempVal1 = StrBin2(2)
    StrBin2(2) = StrBin1(1)
    TempVal2 = StrBin2(1)
    StrBin2(1) = TempVal1
    StrBin1(1) = TempVal2
    
    TempVal1 = StrBin1(4)
    StrBin1(4) = StrBin1(3)
    TempVal2 = StrBin2(4)
    StrBin2(4) = TempVal1
    TempVal3 = StrBin2(3)
    StrBin2(3) = TempVal2
    StrBin1(3) = TempVal3
    
    TempBin1 = StrBin1(1) & StrBin1(2) & StrBin1(3) & StrBin1(4)
    TempBin2 = StrBin2(1) & StrBin2(2) & StrBin2(3) & StrBin2(4)
    
    HelpTempBin1 = Mid(TempBin1, 3, 2)
    HelpTempBin1 = InvertBinary(HelpTempBin1)
    LastTempBin1 = Right(TempBin1, 4)
    TempBin1 = Left(TempBin1, 2)
    TempBin1 = TempBin1 & HelpTempBin1 & LastTempBin1
    
    TempDec1 = BinaryToDecimal(TempBin1)
    TempDec2 = BinaryToDecimal(TempBin2)
    Success = TempDec1 & "-" & TempDec2
    BoundBinary = Success
End Function

Public Function UnBoundBinary(ByVal eBound As String) As String
    Dim Success As String
    Dim TempDec1, TempDec2 As Byte
    Dim TempBin1, TempBin2 As String
    Dim StrBin1(1 To 4) As String
    Dim StrBin2(1 To 4) As String
    Dim HelpTempBin1, LastTempBin1 As String
    Dim Cnt, UCnt As Long
    Dim ActualChar As String
    Dim TextLen As Long
    TextLen = Len(eBound)
    If TextLen <= 0 Then Exit Function
    For Cnt = 1 To TextLen
        ActualChar = Mid(eBound, Cnt, 1)
        If ActualChar = "-" Then
            Exit For
        End If
        TempBin1 = TempBin1 & ActualChar
    Next Cnt
    TempBin2 = Right(eBound, TextLen - Len(TempBin1) - 1)
    TempDec1 = Val(TempBin1)
    TempDec2 = Val(TempBin2)
    
    TempBin1 = DecimalToBinary(TempDec1)
    HelpTempBin1 = Mid(TempBin1, 3, 2)
    HelpTempBin1 = InvertBinary(HelpTempBin1)
    LastTempBin1 = Right(TempBin1, 4)
    TempBin1 = Left(TempBin1, 2)
    TempBin1 = TempBin1 & HelpTempBin1 & LastTempBin1
    
    TempBin2 = DecimalToBinary(TempDec2)
    
    Cnt = 1
    UCnt = 1
    Do
        StrBin1(UCnt) = Mid(TempBin1, Cnt, 2)
        StrBin2(UCnt) = Mid(TempBin2, Cnt, 2)
        Cnt = Cnt + 2
        UCnt = UCnt + 1
    Loop While UCnt <= 4
    Dim TempVal1, TempVal2, TempVal3, TempVal4 As String
    
    TempVal1 = StrBin2(1)
    StrBin2(1) = StrBin1(1)
    TempVal2 = StrBin2(2)
    StrBin2(2) = TempVal1
    StrBin1(1) = TempVal2
    
    TempVal1 = StrBin2(3)
    StrBin2(3) = StrBin1(3)
    TempVal2 = StrBin2(4)
    StrBin2(4) = TempVal1
    TempVal3 = StrBin1(4)
    StrBin1(4) = TempVal2
    StrBin1(3) = TempVal3
    
    TempBin1 = StrBin1(1) & StrBin1(2) & StrBin1(3) & StrBin1(4)
    TempBin2 = StrBin2(1) & StrBin2(2) & StrBin2(3) & StrBin2(4)
    TempDec1 = BinaryToDecimal(TempBin1)
    TempDec2 = BinaryToDecimal(TempBin2)
    Success = TempDec1 & "-" & TempDec2
    UnBoundBinary = Success
End Function

Public Function InvertBinary(ByVal eBinary As String) As String
    Dim Success As String
    Dim ActualChar As String
    Dim Cnt As Long
    Dim TextLen As Long
    TextLen = Len(eBinary)
    If TextLen = 0 Then Exit Function
    For Cnt = 1 To TextLen
        ActualChar = Mid(eBinary, Cnt, 1)
        If ActualChar = "1" Then
            ActualChar = "0"
        Else
            ActualChar = "1"
        End If
        Success = Success & ActualChar
        DoEvents
    Next Cnt
    InvertBinary = Success
End Function

Public Function InvertString(ByVal eText As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim Cnt As Long
    Dim ActualChar As String
    TextLen = Len(eText)
    If TextLen <= 0 Then Exit Function
    For Cnt = 1 To TextLen
        ActualChar = Mid(eText, Cnt, 1)
        Success = ActualChar & Success
        DoEvents
    Next Cnt
    InvertString = Success
End Function

Public Function BinaryEncrypt(ByVal eText As String, Optional ByVal ePass As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualAsc As Byte
    Dim CntAsc As Integer
    Dim TempChar As String
    Dim TempBound As String
    Dim HexaAsc As String
    Dim UnBnd1, UnBnd2 As String
    Dim UnBndAsc1, UnBndAsc2 As Integer
    Dim Cnt, HCnt, KCnt, PWCnt, DPCnt As Long
    Dim DumpTextLen As Long
    Dim DumpTextLenAsc As Integer
    Dim DumpTextLenStr As String
    Const LRndBnd = 39
    Const URndBnd = 45
    
    TextLen = Len(eText)
    If TextLen = 0 Then Exit Function
    
    DumpTextLen = TextLen
    DumpTextLenStr = Str(DumpTextLen)
    KCnt = 2
    For Cnt = 1 To TextLen
        If KCnt > 250 Then KCnt = 2
        KCnt = KCnt + 1
        ActualAsc = Asc(Mid(eText, Cnt, 1))
        Randomize
        CntAsc = Int((URndBnd - LRndBnd + 1) * Rnd + LRndBnd)
        ActualAsc = ActualAsc Xor CntAsc
        TempBound = BoundBinary(ActualAsc, CntAsc)
        UnBnd1 = ""
        UnBnd2 = ""
        For HCnt = 1 To Len(TempBound)
            TempChar = Mid(TempBound, HCnt, 1)
            If TempChar = "-" Then Exit For
            UnBnd1 = UnBnd1 & TempChar
            DoEvents
        Next HCnt
        UnBnd2 = Right(TempBound, Len(TempBound) - Len(UnBnd1) - 1)
        UnBndAsc1 = Val(UnBnd1)
        UnBndAsc2 = Val(UnBnd2)
        CntAsc = Asc(Cnt) + KCnt
        If CntAsc > 255 Then
            CntAsc = CntAsc - 255
        End If
        UnBndAsc1 = UnBndAsc1 + CntAsc
        UnBndAsc2 = UnBndAsc2 + CntAsc
        If UnBndAsc1 > 255 Then
            UnBndAsc1 = UnBndAsc1 - 255
        End If
        If UnBndAsc2 > 255 Then
            UnBndAsc2 = UnBndAsc2 - 255
        End If
        If Len(ePass) > 0 Then
            Dim AscPass As Integer
            For PWCnt = 1 To Len(ePass)
                AscPass = Asc(Mid(ePass, PWCnt, 1))
                UnBndAsc1 = UnBndAsc1 + AscPass
                If UnBndAsc1 > 255 Then
                    UnBndAsc1 = UnBndAsc1 - 255
                End If
                DoEvents
            Next PWCnt
        End If
        For DPCnt = 1 To Len(DumpTextLenStr)
            DumpTextLenAsc = Asc(Mid(DumpTextLenStr, DPCnt, 1))
            UnBndAsc1 = UnBndAsc1 + DumpTextLenAsc
            If UnBndAsc1 > 255 Then UnBndAsc1 = UnBndAsc1 - 255
        Next DPCnt
        Success = Success & Chr(UnBndAsc1) & Chr(UnBndAsc2)
        DoEvents
    Next Cnt
    Dim DumpSuccess As String
    DumpSuccess = Left(Success, Int(Len(Success) / 2))
    Success = Right(Success, Int(Len(Success) / 2))
    Success = Success & DumpSuccess
    BinaryEncrypt = Success
End Function

Public Function BinaryUnCrypt(ByVal eText As String, Optional ByVal ePass As String, Optional ByVal VerifyIntegrity As Boolean) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualAsc, BoundAsc As Integer
    Dim CntAsc As Integer
    Dim TempChar As String
    Dim TempUnBound As String
    Dim HexaAsc As String
    Dim UnBnd1, UnBnd2 As String
    Dim UnBndAsc1, UnBndAsc2 As Byte
    Dim Cnt, HCnt, XCnt, KCnt, DPCnt As Long
    Dim DumpTextLen As Long
    Dim DumpTextLenAsc As Integer
    Dim DumpTextLenStr As String
    
    TextLen = Len(eText)
    If TextLen = 0 Then Exit Function
    
    Dim DumpeText As String
    DumpeText = Left(eText, Int(Len(eText) / 2))
    eText = Right(eText, Int(Len(eText) / 2))
    eText = eText & DumpeText
    
    DumpTextLen = Int(TextLen / 2)
    DumpTextLenStr = Str(DumpTextLen)
    HCnt = 0
    KCnt = 2
    For Cnt = 1 To TextLen Step 2
        HCnt = HCnt + 1
        If KCnt > 250 Then KCnt = 2
        KCnt = KCnt + 1
        ActualAsc = Asc(Mid(eText, Cnt, 1))
        For DPCnt = 1 To Len(DumpTextLenStr)
            DumpTextLenAsc = Asc(Mid(DumpTextLenStr, DPCnt, 1))
            ActualAsc = ActualAsc - DumpTextLenAsc
            If ActualAsc < 0 Then ActualAsc = ActualAsc + 255
        Next DPCnt
        If Len(ePass) > 0 Then
            Dim AscPass As Integer
            Dim PWCnt As Long
            For PWCnt = 1 To Len(ePass)
                AscPass = Asc(Mid(ePass, PWCnt, 1))
                ActualAsc = ActualAsc - AscPass
                If ActualAsc < 0 Then
                    ActualAsc = ActualAsc + 255
                End If
                DoEvents
            Next PWCnt
        End If
        On Error GoTo errhandler
        BoundAsc = Asc(Mid(eText, Cnt + 1, 1))
        CntAsc = Asc(HCnt) + KCnt
        If CntAsc > 255 Then
            CntAsc = CntAsc - 255
        End If
        ActualAsc = ActualAsc - CntAsc
        BoundAsc = BoundAsc - CntAsc
        If ActualAsc < 0 Then
            ActualAsc = ActualAsc + 255
        End If
        If BoundAsc < 0 Then
            BoundAsc = BoundAsc + 255
        End If
        TempUnBound = UnBoundBinary(ActualAsc & "-" & BoundAsc)
        UnBnd1 = ""
        UnBnd2 = ""
        For XCnt = 1 To Len(TempUnBound)
            TempChar = Mid(TempUnBound, XCnt, 1)
            If TempChar = "-" Then Exit For
            UnBnd1 = UnBnd1 & TempChar
        Next XCnt
        UnBnd2 = Right(TempUnBound, Len(TempUnBound) - Len(UnBnd1) - 1)
        UnBndAsc1 = Val(UnBnd1)
        UnBndAsc2 = Val(UnBnd2)
        ActualAsc = UnBndAsc1 Xor UnBndAsc2
        Success = Success & Chr(ActualAsc)
        DoEvents
    Next Cnt
    BinaryUnCrypt = Success
    Exit Function
errhandler:
    If VerifyIntegrity = True Then
        BinaryUnCrypt = "Data corrupted..."
    Else
        Select Case Err.Number
            Case Else
                Err.Clear
        End Select
        BinaryUnCrypt = Success
    End If
End Function

Public Function HexaCrypt(ByVal eText As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualAsc As Integer
    Dim Cnt As Integer
    Dim TempChar As String
    
    TextLen = Len(eText)
    
    If TextLen = 0 Then Exit Function
    
    For Cnt = 1 To TextLen
        ActualAsc = Asc(Mid(eText, Cnt, 1))
        TempChar = DecimalToHexaDecimal(ActualAsc)
        Success = Success & TempChar
    Next Cnt
    
    HexaCrypt = Success
End Function

Public Function HexaUncrypt(ByVal eText As String) As String
    Dim Success As String
    Dim TextLen As Long
    Dim ActualAsc As Integer
    Dim Cnt As Integer
    Dim TempChar As String
    
    TextLen = Len(eText)
    
    If TextLen < 2 Then Exit Function
    
    For Cnt = 1 To TextLen Step 2
        TempChar = Mid(eText, Cnt, 2)
        ActualAsc = HexaDecimalToDecimal(TempChar)
        TempChar = Chr$(ActualAsc)
        Success = Success & TempChar
    Next Cnt
    
    HexaUncrypt = Success
End Function

Public Function GeneratePassword(ByVal gLen As Long) As String
    If gLen = 0 Then Exit Function
    Dim lNum As Long
    Dim Cnt As Long
    Cnt = 0
    Do
        Randomize
        lNum = Rnd * 127
        Select Case lNum
            Case 48 To 57, 97 To 122
                GeneratePassword = GeneratePassword & Chr$(lNum)
                Cnt = Cnt + 1
            Case Else
        End Select
    Loop Until Cnt = gLen
End Function
