Convert any string, Text, password in secret code from visualization

Sub Encrypt_Decrypt()
    Dim i As Integer
    Dim Estr As String, Dstr As String
     
    Dstr = "password"
     'Encrypt string
    For i = 1 To Len(Dstr)
        Estr = Estr & Chr(Asc(Mid(Dstr, i, 1)) + 30)
        ActiveCell.Value = Estr
        ActiveCell.Offset(1).Select
    Next i
    Dstr = ""
     'Decrypt String
    For i = 1 To Len(Estr)
        Dstr = Dstr & Chr(Asc(Mid(Estr, i, 1)) - 30)
        ActiveCell.Value = Dstr
        ActiveCell.Offset(1).Select
    Next i
End Sub

Another way of doing the same thing

Function EnCrypt(ByVal CryptString, Optional Password As String = "") As String
EnCrypt = ConvertString(Password) & "|" & ConvertString(CryptString)
End Function
Function DeCrypt(ByVal CryptString, Optional Password As String = "") As String
Dim iPtr As Integer
Dim sPass As String, sData As String
iPtr = InStr(CryptString, "|")
If iPtr > 1 Then sPass = ConvertString(Left$(CryptString, iPtr - 1))
If sPass = Password Then
    DeCrypt = ConvertString(Right$(CryptString, Len(CryptString) - iPtr))
Else
    DeCrypt = CryptString
End If
End Function

Private Function ConvertString(ByVal CryptString As String) As String
Dim bChar As Byte
Dim I As Integer

For I = 1 To Len(CryptString)
    bChar = Asc(Mid$(CryptString, I, 1)) Xor &HFF
    Mid$(CryptString, I, 1) = Chr(bChar)
Next I
ConvertString = CryptString
End Function


Function myDecryption(DataIn As String) As String
On Error GoTo endFunction
Dim arkdata1 As Long
Dim strDataOut As String
Dim intXOrValue1 As Integer
Dim intXOrValue2 As Integer
For arkdata1 = 1 To (Len(DataIn) / 2)
    intXOrValue1 = Val("&H" & (Mid$(DataIn, (2 * arkdata1) - 1, 2)))
    intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1))
    strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2)
Next arkdata1
myDecryption = strDataOut
endFunction:
On Error GoTo 0
End Function



Function myEncryption(DataIn As String) As String
Dim arkdata1 As Long
Dim strDataOut As String
Dim Temp As Integer
Dim tempstring As String
Dim intXOrValue1 As Integer
Dim intXOrValue2 As Integer
On Error GoTo endFunction
For arkdata1 = 1 To Len(DataIn)
    intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1))
    intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1))
    Temp = (intXOrValue1 Xor intXOrValue2)
    tempstring = Hex(Temp)
    If Len(tempstring) = 1 Then tempstring = "0" & tempstring
    strDataOut = strDataOut + tempstring
Next arkdata1
myEncryption = strDataOut
endFunction:
On Error GoTo 0
End Function

Using MD5 Conversion (Oneway Conversion)

Sub test()
    Debug.Print MD5Hex("Ajeet Kumar")
End Sub

Public Function MD5Hex(textString As String) As String
    Dim enc
    Dim textBytes() As Byte
    Dim bytes
    Dim outstr As String
  
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    textBytes = textString
    bytes = enc.ComputeHash_2((textBytes))
    
    For pos = 1 To LenB(bytes)
        outstr = outstr & LCase(Right("0" & Hex(AscB(MidB(bytes, pos, 1))), 2))
    Next
    MD5Hex = outstr
    Set enc = Nothing
End Function

Private Sub TestMD5()
    Debug.Print FileToMD5Hex("C:\test.txt")
    Debug.Print FileToSHA1Hex("C:\test.txt")
End Sub

Public Function FileToMD5Hex(sFileName As String) As String
    Dim enc
    Dim bytes
    Dim outstr As String
    Dim pos As Integer
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFileName)
    bytes = enc.ComputeHash_2((bytes))
    'Convert the byte array to a hex string
    For pos = 1 To LenB(bytes)
        outstr = outstr & LCase(Right("0" & Hex(AscB(MidB(bytes, pos, 1))), 2))
    Next
    FileToMD5Hex = outstr
    Set enc = Nothing
End Function

Public Function FileToSHA1Hex(sFileName As String) As String
    Dim enc
    Dim bytes
    Dim outstr As String
    Dim pos As Integer
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFileName)
    bytes = enc.ComputeHash_2((bytes))
    'Convert the byte array to a hex string
    For pos = 1 To LenB(bytes)
        outstr = outstr & LCase(Right("0" & Hex(AscB(MidB(bytes, pos, 1))), 2))
    Next
    FileToSHA1Hex = outstr 'Returns a 40 byte/character hex string
    Set enc = Nothing
End Function

Private Function GetFileBytes(ByVal path As String) As Byte()
    Dim lngFileNum As Long
    Dim bytRtnVal() As Byte
    lngFileNum = FreeFile
    If LenB(Dir(path)) Then ''// Does file exist?
        Open path For Binary Access Read As lngFileNum
        ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53
    End If
    GetFileBytes = bytRtnVal
    Erase bytRtnVal
End Function

Option Explicit

Sub test()
    Dim strmsg As String
    strmsg = EnCrypt("Kumar", 1235)
    Debug.Print strmsg
    Debug.Print DeCrypt(strmsg, 1235)
End Sub
Function EnCrypt(ByVal CryptString, Optional Password As String = "") As String
    EnCrypt = ConvertString(Password) & "|" & ConvertString(CryptString)
End Function
Function DeCrypt(ByVal CryptString, Optional Password As String = "") As String
    Dim iPtr As Integer
    Dim sPass As String, sData As String
    iPtr = InStr(CryptString, "|")
    If iPtr > 1 Then sPass = ConvertString(Left$(CryptString, iPtr - 1))
    If sPass = Password Then
        DeCrypt = ConvertString(Right$(CryptString, Len(CryptString) - iPtr))
    Else
        DeCrypt = CryptString
    End If
End Function

Private Function ConvertString(ByVal CryptString As String) As String
    Dim bChar As Byte
    Dim I As Integer
    For I = 1 To Len(CryptString)
        bChar = Asc(Mid$(CryptString, I, 1)) Xor &HFF
        Mid$(CryptString, I, 1) = Chr(bChar)
    Next I
    ConvertString = CryptString
End Function