Sub CrackPW()
' Decrypts passwords on IMail 7.x
' Contributed by ives.stoddard@eurekafarms.com

Dim UserLen As Integer
Dim PassLen As Integer
Dim PassCrack As String
Dim i, j As Integer

User = ActiveCell.Value
Pass = ActiveCell.Offset(0, 1).Value

UserLen = Len(User)
PassLen = Len(Pass)

'MsgBox User & " : " & Pass

For i = 1 To PassLen / 2
'   Take letter of password, subtract asciival of corresponding letter of user - from mod len of user 
    ASCII = ""
    ASCII = Mid(Pass, i * 2 - 1, 2)
    ASCIIval = Hex2Dec(ASCII)
    j = ((i - 1) Mod UserLen) + 1
    
    PassCrack = PassCrack & Chr(ASCIIval - Asc(Mid(User, j, 1)))
Next

MsgBox PassCrack

End Sub

Public Function Hex2Dec(ByVal sHex As String) As Long
    Dim i As Integer
    Dim nDec As Long
    Const HexChar As String = "0123456789ABCDEF"
    
    For i = Len(sHex) To 1 Step -1
        nDec = nDec + (InStr(1, HexChar, Mid(sHex, i, 1)) - 1) * 16 ^ (Len(sHex) - i)
    Next i
    Hex2Dec = CStr(nDec)
End Function