有没有vb对密码字符进行加密与解密的程序。

Question

哪位高手有，，如果有的话，请给我，谢谢了。万分感激。

Answer 1

Public Function Encode(ByVal S As String) As String '加密函数
On Error GoTo acd
    If Len(S) = 0 Then Exit Function
    Dim Buff() As Byte
    Buff = StrConv(S, vbFromUnicode)
    Dim i As Long
    Dim j As Byte
    Dim k As Byte, m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim outs As String
    i = UBound(Buff) + 1
    outs = Space(2 * i)
    Dim Temps As String
    For i = 0 To UBound(Buff)
        Randomize Time
        j = CByte(5 * (Math.Rnd()) + 0) '
        Buff(i) = Buff(i) Xor j
        k = Buff(i) Mod Len(mstr)
        m = Buff(i) \ Len(mstr)
        m = m * 2 ^ 3 + j
        Temps = Mid(mstr, k + 1, 1) + Mid(mstr, m + 1, 1)
        Mid(outs, 2 * i + 1, 2) = Temps
     Next
     Encode = outs
Exit Function
acd:
End FunctionPublic Function Decode(ByVal S As String) As String '解密函数
    On Error GoTo acd
    Dim i As Long
    Dim j As Byte
    Dim k As Byte
    Dim m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim t1 As String, t2 As String
    Dim Buff() As Byte
    Dim n As Long
    n = 0
    For i = 1 To Len(S) Step 2
        t1 = Mid(S, i, 1)
        t2 = Mid(S, i + 1, 1)
        k = InStr(1, mstr, t1) - 1
        m = InStr(1, mstr, t2) - 1
        j = m \ 2 ^ 3
        m = m - j * 2 ^ 3
        ReDim Preserve Buff(n)
        Buff(n) = j * Len(mstr) + k
        Buff(n) = Buff(n) Xor m
        n = n + 1
     Next
     Decode = StrConv(Buff, vbUnicode)
     Exit Function
acd:
     Decode = ""
End Function

Answer 2

Public Function Encode(ByVal S As String, password As String) As String
On Error GoTo acd
    If Len(S) = 0 Then Exit Function
    Dim Buff() As Byte
    Buff = StrConv(S, vbFromUnicode)
    Dim i As Long
    Dim j As Byte
    Dim k As Byte, m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim outs As String
    i = UBound(Buff) + 1
    outs = Space(2 * i)
    Dim Temps As String
    For i = 0 To UBound(Buff)
        Randomize Time
        j = CByte(5 * (Math.Rnd()) + 0)
        Buff(i) = Buff(i) Xor j
        k = Buff(i) Mod Len(mstr)
        m = Buff(i) \ Len(mstr)
        m = m * 2 ^ 3 + j
        Temps = Mid(mstr, k + 1, 1) + Mid(mstr, m + 1, 1)
        Mid(outs, 2 * i + 1, 2) = Temps
     Next
     Encode = outs
Exit Function
acd:
End Function
'解密函数
Public Function Decode(ByVal S As String, password As String) As String
If password <> "eee" Then Exit Function    On Error GoTo acd
    Dim i As Long
    Dim j As Byte
    Dim k As Byte
    Dim m As Byte
    Dim mstr As String
    mstr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    Dim t1 As String, t2 As String
    Dim Buff() As Byte
    Dim n As Long
    n = 0
    For i = 1 To Len(S) Step 2
        t1 = Mid(S, i, 1)
        t2 = Mid(S, i + 1, 1)
        k = InStr(1, mstr, t1) - 1
        m = InStr(1, mstr, t2) - 1
        j = m \ 2 ^ 3
        m = m - j * 2 ^ 3
        ReDim Preserve Buff(n)
        Buff(n) = j * Len(mstr) + k
        Buff(n) = Buff(n) Xor m
        n = n + 1
     Next
     Decode = StrConv(Buff, vbUnicode)
     Exit Function
acd:
     Decode = ""
End FunctionPrivate Sub Command1_Click()
Text2.Text = Decode(Text1.Text, Text3.Text)End SubPrivate Sub Form_Load()
Text1.Text = Encode(45, "eee")
End Sub

Answer 3

这个很好用:
Private Function GetCodeO(ByVal strValue As String) As String
    Randomize
    Dim ll As Integer
    Dim AscNumber As Integer
    Dim i As Integer
    Dim hh As String
    Dim ss As String
    Dim mm As String
    Dim j As Integer
    Dim temp As String
    Dim Temp2 As String
    Dim Temp1 As String
    Dim temp3 As String
    Dim temp4 As String
        
    ll = Len(strValue)  '加密字符长度
    If ll = 0 Then
        GetCodeO = ""
    Else
    '**************************************
        i = 1
        For i = 1 To ll
            AscNumber = Asc(Mid(strValue, i, 1))   '取ASC码
            hh = Hex(AscNumber) '换成16进制码
            If Len(hh) < 2 Then '不够二位的补0
                hh = "0" & hh
            End If
            For j = 1 To Len(hh)
                ss = Mid(hh, j, 1)
                Select Case ss
                Case "0"
                    mm = "0000"
                Case "1"
                    mm = "0001"
                Case "2"
                    mm = "0010"
                Case "3"
                    mm = "0011"
                Case "4"
                    mm = "0100"
                Case "5"
                    mm = "0101"
                Case "6"
                    mm = "0110"
                Case "7"
                    mm = "0111"
                Case "8"
                    mm = "1000"
                Case "9"
                    mm = "1001"
                Case "A"
                    mm = "1010"
                Case "B"
                    mm = "1011"
                Case "C"
                    mm = "1100"
                Case "D"
                    mm = "1101"
                Case "E"
                    mm = "1110"
                Case "F"
                    mm = "1111"
                End Select
                temp = temp & mm
            Next j
        Next i
        '**************************************
        '  Debug.Print "G", temp
        Temp2 = ""
        temp3 = ""
        i = 1
        For i = 1 To Len(temp)
            If i / 2 = Int(i / 2) Then
                Temp2 = Temp2 & Mid(temp, i, 1)
            Else
                temp3 = temp3 & Mid(temp, i, 1)
            End If
        Next
        temp = Temp2 & temp3
        '**************************************
        Temp1 = Right(temp, 7)
        temp = Temp1 & Left(temp, Len(temp) - 7)
        Temp1 = Left(temp, Len(temp) / 2)
        temp = Right(temp, Len(temp) / 2) & Temp1
        Temp1 = Mid(temp, Len(temp) / 2, 2)
        temp = Temp1 & temp & Temp1
        '**************************************
        Temp1 = ""
        ss = ""
        mm = ""
        j = 1
        For j = 1 To Len(temp) Step 4
            ss = Mid(temp, j, 4)
            Select Case ss
            Case "0000"
                mm = "F"
            Case "0001"
                mm = "b"
            Case "0010"
                mm = "2"
            Case "0011"
                mm = "P"
            Case "0100"
                mm = "V"
            Case "0101"
                mm = "j"
            Case "0110"
                mm = "W"
            Case "0111"
                mm = "N"
            Case "1000"
                mm = "q"
            Case "1001"
                mm = "m"
            Case "1010"
                mm = "7"
            Case "1011"
                mm = "i"
            Case "1100"
                mm = "d"
            Case "1101"
                mm = "c"
            Case "1110"
                mm = "L"
            Case "1111"
                mm = "g"
            End Select
            Temp1 = Temp1 & mm
        Next j
        temp = Temp1
        '**************************************
        i = 1
        Temp1 = ""
        For i = 1 To Len(temp)
            Temp1 = Temp1 & Chr(Asc(Mid(temp, i, 1)) Xor 17)
        Next i
        temp = Temp1
        '**************************************
        i = 1
        Temp1 = ""
        For i = 1 To Len(temp)
            Temp2 = Chr(Int(Rnd * 25))
            temp3 = Chr(Asc(Mid(temp, i, 1)) Xor Asc(Temp2))
            Temp1 = Temp1 & temp3 & Chr(Asc(Temp2) + 65)
        Next i
        '**************************************
        temp = Temp1
        GetCodeO = temp
    End If
    
End Function

Answer 4

'====================
'解密程序 (支持中文)
'====================
Private Function GetPasswordO(ByVal temp As String) As String
    On Error GoTo errH:
    Dim ll As Integer
    Dim i As Integer
    Dim ss As String
    Dim mm As String
    Dim j As Integer
    Dim hh As String
    Dim DD As Long
    Dim TT As String
    Dim Temp1 As String
    Dim Temp2 As String
    Dim temp3 As String
    '**************************************
    If Len(temp) = 0 Then
        GetPasswordO = ""
    Else
    '********************************
        Temp1 = ""
        i = 1
        For i = 1 To Len(temp) Step 2
            Temp1 = Temp1 & Chr(Asc(Mid(temp, i, 1)) Xor Asc(Mid(temp, i + 1, 1)) - 65)
        Next i
        temp = Temp1
        '********************************
        i = 1
        Temp1 = ""
        For i = 1 To Len(temp)
            Temp1 = Temp1 & Chr(Asc(Mid(temp, i, 1)) Xor 17)
        Next i
        temp = Temp1
        '********************************
        Temp1 = ""
        mm = ""
        ss = ""
        j = 1
        For j = 1 To Len(temp)
            ss = Mid(temp, j, 1)
            Select Case ss
            Case "F"
                mm = "0000"
            Case "b"
                mm = "0001"
            Case "2"
                mm = "0010"
            Case "P"
                mm = "0011"
            Case "V"
                mm = "0100"
            Case "j"
                mm = "0101"
            Case "W"
                mm = "0110"
            Case "N"
                mm = "0111"
            Case "q"
                mm = "1000"
            Case "m"
                mm = "1001"
            Case "7"
                mm = "1010"
            Case "i"
                mm = "1011"
            Case "d"
                mm = "1100"
            Case "c"
                mm = "1101"
            Case "L"
                mm = "1110"
            Case "g"
                mm = "1111"
            Case Else
                GetPasswordO = ""
                Exit Function
            End Select
            Temp1 = Temp1 & mm
        Next j
        temp = Temp1
        '**************************************
        temp = Left(temp, Len(temp) - 2)
        temp = Right(temp, Len(temp) - 2)
        Temp1 = Left(temp, Len(temp) / 2)
        temp = Right(temp, Len(temp) / 2) & Temp1
        Temp1 = Left(temp, 7)
        temp = Right(temp, Len(temp) - 7) & Temp1
        '*************************************
        Temp1 = ""
        Temp2 = Left(temp, Len(temp) / 2)
        temp3 = Right(temp, Len(temp) / 2)
        i = 1
        For i = 1 To Len(Temp2)
            Temp1 = Temp1 & Mid(temp3, i, 1) & Mid(Temp2, i, 1)
        Next
        temp = Temp1
        '**************************************
        ll = Len(temp)
        i = 1
        For i = 1 To ll Step 4
            ss = Mid(temp, i, 4)
            Select Case ss
            Case "0000"
                 mm = "0"
            Case "0001"
                 mm = "1"
            Case "0010"
                 mm = "2"
            Case "0011"
                 mm = "3"
            Case "0100"
                 mm = "4"
            Case "0101"
                 mm = "5"
            Case "0110"
                 mm = "6"
            Case "0111"
                 mm = "7"
            Case "1000"
                 mm = "8"
            Case "1001"
                 mm = "9"
            Case "1010"
                 mm = "A"
            Case "1011"
                 mm = "B"
            Case "1100"
                 mm = "C"
            Case "1101"
                 mm = "D"
            Case "1110"
                 mm = "E"
            Case "1111"
                 mm = "F"
            End Select
            hh = hh & mm
        Next i
        '**************************************
        j = 1
        While j <= Len(hh)
            If Mid(hh, j, 1) < "8" Then
                DD = CDec("&H" & Mid(hh, j, 2))
                TT = TT & Chr(DD)
                j = j + 2
            Else
                DD = CDec("&H" & Mid(hh, j, 4))
                TT = TT & Chr(DD)
                j = j + 4
            End If
        Wend
        '**************************************
        GetPasswordO = TT
    End If
    Exit Function
errH:
    GetPasswordO = ""
End Function

Answer 5

不知道是谁写的，不过很好用，谢谢作者！
Public Function StrToHex(ByVal S As String) As String
    On Error Resume Next
    Dim ByteArr() As Byte
    ByteArr = StrConv(S, vbFromUnicode)
    Dim Temps As String
    Dim Temp As Byte
    Dim i As Long
    Dim Outs As String
    For i = 0 To UBound(ByteArr)
        Temp = ByteArr(i)
        Temps = Hex(Temp)
        Temps = right("00" + Temps, 2)
        Outs = Outs + Temps
    Next
    StrToHex = Outs
End FunctionPublic Function HexToStr(ByVal S As String) As String
    On Error Resume Next
    Dim ByteArr() As Byte
    Dim Temps As String
    Dim Temp As Byte
    Dim i As Long
    Dim j As Long
    j = 0
    Dim Outs As String
    For i = 1 To Len(S) Step 2
        Temps = Mid(S, i, 2)
        Temp = Val("&H" & Temps)
        ReDim Preserve ByteArr(j)
        ByteArr(j) = Temp
        j = j + 1
    Next
    Outs = StrConv(ByteArr, vbUnicode)
    HexToStr = Outs
End Function