高分求一字符串的加密与解密函数！

给你一个类：'将类命名为clsPassWord
Option ExplicitDim strgetAcc As String
Dim strgetPW As String
Dim strCrlf As StringPrivate Sub Class_Initialize()
    strCrlf = Chr(10)
End SubPublic Function LockString(strS1, strS2)
    Dim intLen1 As Long, intLen2 As Long, intLenAll As Long, strLenPWR As String
    Dim I As Long, K As Long, M As Long, N As Long
    Dim strResult As String
    Dim strRnd As String
    Dim btTmp1 As Byte
    Dim btTmp2 As Byte
    Dim btRTmp As Byte
    Dim strTmp As String
    Dim chrTmp1 As String
    Dim chrTmp2 As String
    Dim btarrTmp1() As Byte
    Dim btarrTmp2() As Byte
    Dim intTmp As Long
    Dim intPos As Long
    Dim strOffset As String
    Dim strPWRegion As String
    Dim strHead As String
    Dim strVar As String
    Dim strCryp As String

    strCryp = strS1 & strCrlf & StrReverse(strS2)
    intLen1 = Len(strCryp)
    intLen2 = Len(strS2)
    K = intLen1
    N = intLen2
    Call Randomize(Timer)
    ReDim btarrTmp1(K)
    ReDim btarrTmp2(N)
    strTmp = ""

    For I = 1 To K
        btarrTmp1(I) = Asc(Mid(strCryp, I, 1))
    Next

    For M = 1 To N
        btarrTmp2(M) = Asc(Mid(strS2, M, 1))
    Next

    For I = 0 To K
        btRTmp = btarrTmp1(I)
        For M = 0 To N
            btTmp2 = btarrTmp2(M)
            btRTmp = btRTmp Xor btTmp2
        Next
        If btRTmp <> 0 Then
            chrTmp2 = Chr(btRTmp)
        Else
            chrTmp2 = "[B]"
        End If
        If btRTmp = 34 Then
            chrTmp2 = "[CHRSPEC]"
        End If
        strTmp = strTmp & chrTmp2
    Next
    chrTmp1 = ""
    chrTmp2 = ""
    strPWRegion = strTmp
    strLenPWR = Chr(Len(strPWRegion) + 16)

    strRnd = GetRndString()    intTmp = Len(strRnd) + 16
    chrTmp1 = Chr(intTmp + 11)
    strVar = strLenPWR & chrTmp1 & strRnd
    K = 7
    strHead = ""
    For I = 0 To 7
        intTmp = Rnd * 25 + 97
        If intTmp = 0 Then
            intTmp = 65
        End If
        chrTmp1 = Chr(intTmp)
        strHead = strHead & chrTmp1
    Next

    strResult = strHead & strVar
    intPos = Len(strResult)
    strTmp = ""
    K = Len(strPWRegion)
    For I = 1 To K
        strRnd = GetRndString()
        intTmp = Len(strRnd)
        chrTmp1 = Mid(strPWRegion, I, 1)
        chrTmp2 = Chr(intTmp + 2)
        strTmp = strTmp & chrTmp1 & chrTmp2 & strRnd
    Next
    strTmp = strResult & strTmp
    strTmp = Replace(strTmp, "'", "[CHRSPEC]")
    LockString = strTmp
End FunctionPublic Property Get GetAcc()
    GetAcc = strgetAcc
End PropertyPublic Property Get GetPW()
    GetPW = strgetPW
End PropertyPublic Sub UnLockString(strS1, strS2)
    Dim I As Long, K As Long, M As Long, N As Long
    Dim intLen1 As Long
    Dim intLen2 As Long
    Dim intPWLen As Long
    Dim chrarrTmp() As String
    Dim strTmp As String
    Dim btTmp As Byte
    Dim intTmp As Long
    Dim chrTmp As String
    Dim intPos As Long
    Dim btRTmp As Byte
    Dim strResult As String
    Dim btarrTmp2() As Byte
    Dim strarrTmp() As String
    Dim strC As String

    strTmp = Replace(strS1, "[CHRSPEC]", "'")
    intLen2 = Len(strS2)
    chrTmp = Mid(strTmp, 9, 1)
    intTmp = Asc(chrTmp)
    intPWLen = intTmp - 16 '取得有效数据长度

    chrTmp = Mid(strTmp, 10, 1)
    intTmp = Asc(chrTmp)
    intPos = intTmp - 16 '取得有效数据的开始位置
    K = intPWLen - 1
    For I = 0 To K
        chrTmp = Mid(strTmp, intPos, 1)
        strResult = strResult & chrTmp
        chrTmp = Mid(strTmp, intPos + 1, 1)
        intTmp = Asc(chrTmp)
        intPos = intPos + intTmp
    Next
    intLen1 = Len(strResult)

    N = intLen2
    ReDim btarrTmp2(N)
    For M = 1 To N
        btarrTmp2(M) = Asc(Mid(strS2, M, 1))
    Next
    strResult = Replace(strResult, "[CHRSPEC]", "'")
    K = Len(strResult)

    strTmp = ""
    For I = 1 To K
        strC = Mid(strResult, I, 3)
        If strC <> "[B]" Then
            chrTmp = Mid(strResult, I, 1)
            btRTmp = Asc(chrTmp)
        Else
            I = I + 2
            K = K - 3
            btRTmp = 0
        End If
        For M = 1 To N
            btTmp = btarrTmp2(M)
            btRTmp = btRTmp Xor btTmp
        Next
        If btRTmp > 0 Then
            strTmp = strTmp & Chr(btRTmp)
        End If
    Next
    If InStr(1, strTmp, strCrlf) > 0 Then
        strarrTmp = Split(strTmp, strCrlf)
        strgetAcc = strarrTmp(0)
        strgetPW = StrReverse(strarrTmp(1))
    Else
        strgetAcc = ""
        strgetPW = ""
    End If
End SubPrivate Function GetRndString()
    Dim I, K
    Dim strTmp
    Dim intTmp
    Dim intStyle

    K = Rnd * 6 + 2
    intStyle = Int(Rnd * 9 + 1)
    For I = 1 To K
     intStyle = Int(Rnd * 9 + 1)
        Select Case intStyle
                Case 0, 1, 2, 3
                    'intTmp = Rnd * 13 + 7
                Case 4, 5, 6
                    'intTmp = Rnd * 42 + 48
                Case 7, 8, 9, 10
                    'intTmp = Rnd * 25 + 97
        End Select
        intTmp = Rnd * 25 + 97
        If intTmp = 0 Then
            intTmp = 65
        End If
        strTmp = strTmp & Chr(intTmp)
    Next
    GetRndString = strTmp
End Function'使用方法简介：
    Dim clsPW As New clsPassWord
    Dim strPW As String
    strPW = clsPW.LockString("UserName", "PassWord")
    clsPW.UnLockString strPW, "PassWord"
    Msgbox "UserName" & clsPW.GetAcc
    Msgbox "PW=" & clsPW.GetPW

看看这个
没有测试
Option Explicit
'This encryption algorithim first gets the day of'the current date (including the character "0" if'applicable in two digits), converts both characters'into ascii values, adds them to a prime number and'uses that as the encryption key. The value is'encrypted under a simple ascii value addition and'can be deduced from the first few characters of the'encrypted string. The first character of the'encrypted data is ALWAYS the ascii value of how many'characters after it is the decrypt key, ie the'length of the decrypt key is the ascii value of the'first character.''=================================================='I realise that a better method would be to use a'"rolling key" method, ie, changing or incrementing'the encryption key as each character is encrypted.'But. I'll leave that to you.'DiskJunky'==================================================
Declare Function GetTickCount Lib "kernel32" () As LongConst BaseKey = 43 'used to encrypt the main keyConst AddToKey = 17 'added to help form the main key
Private Function GenerateKey() As Integer'generates the main key use for encryption.
Dim MilliSecond As Integer
'I changed the daynum value to hold a second value'instead of a day value for more variances.'Changed again to an even shorter time value.MilliSecond = (GetTickCount Mod 100) '/ 1000)GenerateKey = Val(Trim(Str(Format(MilliSecond, "00")))) + AddToKey 'Second(Time)End Function
Public Function EncryptData(Text As String) As StringDim Counter As IntegerDim DayNum As StringDim DayKey As IntegerDim RetData As StringDim Encrypt As String
'if text is empty, return emptyIf Text = "" ThenEncryptData = ""Exit FunctionEnd If
DayKey = GenerateKey
'store the amount of digits daykey is, in the first'character.RetData = Chr(Len(Trim(Str(DayKey))))RetData = RetData & EncryptKey(Trim(Str(DayKey)))
'encrypt the rest of the dataFor Counter = 1 To Len(Text)DoEventsEncrypt = Trim(Chr((Asc(Mid(Text, Counter, 1)) + DayKey) Mod 256))RetData = RetData & EncryptNext Counter
EncryptData = RetDataEnd Function
Public Function DecryptData(Text As String) As StringDim Counter As IntegerDim DayNum As StringDim DayKey As IntegerDim RetData As StringDim Decrypt As StringDim DecryptNum As Integer
'get the amount of digits the key is and decrypt the'keyIf Text = "" ThenExit FunctionEnd If
DayNum = GetKeyLength(Text)DayKey = Val(DecryptKey(Mid(Text, 2, Val(DayNum))))'DayKey = DayKey
'Dim test As Variant'decrypt the rest of the dataFor Counter = (Val(DayNum) + 2) To Len(Text)DoEvents' test = Mid(Text, Counter, 1)' test = Asc(Mid(Text, Counter, 1)) - DayKey' test = Chr(Asc(Mid(Text, Counter, 1)) - DayKey)DecryptNum = (Asc(Mid(Text, Counter, 1)) - DayKey) Mod 255If DecryptNum < 0 ThenDecryptNum = 255 + DecryptNumElseDecryptNum = DecryptNum Mod 256End If
Decrypt = Right(Chr(DecryptNum), 1)RetData = RetData & DecryptNext Counter
DecryptData = RetDataEnd Function
Public Function GetKeyLength(Text As String) As StringDim KeyLength As Integer'get the amount of digits the key is and decrypt the'keyIf Text = "" ThenExit FunctionEnd If
KeyLength = Len(Str(Asc(Mid(Text, 1, 1))))
GetKeyLength = KeyLengthEnd Function
Private Function EncryptKey(Key As String) As String'adds the encryption key to the ASCII value of each'character.
Dim Counter As IntegerDim NewKey As String
On Error Resume Next
For Counter = 1 To Len(Key)NewKey = NewKey & Right(Chr(Asc(Mid(Key, Counter, 1)) + BaseKey), 1)Next Counter
EncryptKey = NewKeyEnd Function
Private Function DecryptKey(Key As String) As String'subtracts the encryption key from the ASCII value'of each character.
Dim Counter As IntegerDim NewKey As StringDim test As Variant
On Error Resume Next
For Counter = 1 To Len(Key)test = Mid(Key, Counter, 1)test = Asc(Mid(Key, Counter, 1))test = Chr(Asc(Mid(Key, Counter, 1)) - BaseKey)test = Right(Chr(Asc(Mid(Key, Counter, 1)) - BaseKey), 1)NewKey = NewKey & Right(Chr(Asc(Mid(Key, Counter, 1)) - BaseKey), 1)Next Counter
If Key = "" Then NewKey = ""
DecryptKey = NewKeyEnd Function

你只要在论坛上搜一下关键词"加密"或"base64"，会有很多结果的
http://expert.csdn.net/Expert/TopicView1.asp?id=2211834
...

http://www.csdn.net/Develop/list_article.asp?author=jlum99

一个类  dsEncrypt.clsOption Explicit   Private LCW As Integer                 'Length of CodeWord
   Private LS2E As Integer                 'Length of String to be Encrypted
   Private LAM As Integer                 'Length of Array Matrix
   Private MP As Integer                    'Matrix Position
   Private Matrix As String                  'Starting Matrix
   Private mov1 As String                    'First Part of Replacement String
   Private mov2 As String                    'Second Part of Replacement String
   Private CodeWord As String            'CodeWord
   Private CWL As String                    'CodeWord Letter
   Private EncryptedString As String     'String to Return for Encrypt or String to UnEncrypt for UnEncrypt
   Private EncryptedLetter As String     'Storage Variable for Character just Encrypted
   Private strCryptMatrix(97) As String 'Matrix Array
Public Property Let KeyString(sKeyString As String)
    CodeWord = sKeyString
End Property
Public Function Encrypt(mstext As String) As String
    Dim X As Integer                    ' Loop Counter
    Dim Y As Integer                    'Loop Counter
    Dim Z As Integer                     'Loop Counter
    Dim C2E As String                   'Character to Encrypt
    Dim Str2Encrypt As String        'Text from TextBox    Str2Encrypt = mstext
    LS2E = Len(mstext)
    LCW = Len(CodeWord)
    EncryptedLetter = ""
    EncryptedString = ""    Y = 1
    For X = 1 To LS2E
        C2E = Mid(Str2Encrypt, X, 1)
        MP = InStr(1, Matrix, C2E, 0)
        CWL = Mid(CodeWord, Y, 1)
        For Z = 1 To LAM
            If Mid(strCryptMatrix(Z), MP, 1) = CWL Then
                EncryptedLetter = Left(strCryptMatrix(Z), 1)
                EncryptedString = EncryptedString + EncryptedLetter
                Exit For
            End If
        Next Z
        Y = Y + 1
        If Y > LCW Then Y = 1
    Next X
    Encrypt = EncryptedStringEnd Function
Private Sub Class_Initialize()    Dim W As Integer 'Loop Counter to set up Matrix
    Dim X As Integer     'Loop through Matrix

    Matrix = "8x3p5BeabcdfghijklmnoqrstuvwyzACDEFGHIJKLMNOPQRSTUVWXYZ 1246790-.#/\!@$<>&*()[]{}';:,?=+~`^|%_"
    Matrix = Matrix + Chr(13)  'Add Carriage Return to Matrix
    Matrix = Matrix + Chr(10)  'Add Line Feed to Matrix
    Matrix = Matrix + Chr(34)  'Add "
    ' Unique String used to make Matrix - 8x3p5Be
    ' Unique String can be any combination that has a character only ONCE.
    ' EACH Letter in the Matrix is Input ONLY once.
    W = 1
    LAM = Len(Matrix)
    strCryptMatrix(1) = Matrix

    For X = 2 To LAM ' LAM = Length of Array Matrix
        mov1 = Left(strCryptMatrix(W), 1)   'First Character of strCryptMatrix
        mov2 = Right(strCryptMatrix(W), (LAM - 1))   'All but First Character of strCryptMatrix
        strCryptMatrix(X) = mov2 + mov1  'Makes up each row of the Array
        W = W + 1
    Next X
End Sub用法：
Private MydsEncrypt As dsEncrypt
Set MydsEncrypt = New dsEncrypt
MydsEncrypt.KeyString = ("KAT123233344HER")
加密：
y= MydsEncrypt.Encrypt(x)解密：
x= MydsEncrypt.Encrypt(y)

不用其他的加密算法，加密完成后，在加密后的字符串前面和后面加一个不带空格的定长字符串。解密之前，用mid(str,n,len(str)-2n)来取得需要解密的字符串。
（str是加密后的字符串，n是定长字符串的长度。）
这样应该就能符合你的要求。

调试易

高分求一字符串的加密与解密函数！

解决方案 »

高分 求一字符串的加密与解密函数！

解决方案 »

高分求一字符串的加密与解密函数！