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

[juit]

产生的加密字符串前后不要有空格，因为我是把这个密码写在INI文件中，如果有空格的话，我用API读INI后，因为去掉了前后的空格，使密码不能还原。就这一点要求就OK了。


网上的这个函数就不要了：
Public Function StringEnDeCodecn(strSource As String, MA) As String
'该函数只对中西文起到加密作用
'参数为：源文件，密码

[海牛]

给你一个类：

'将类命名为clsPassWord
Option Explicit

Dim strgetAcc As String
Dim strgetPW As String
Dim strCrlf As String

Private Sub Class_Initialize()
strCrlf = Chr(10)
End Sub

Public 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 Function

Public Property Get GetAcc()
GetAcc = strgetAcc
End Property

Public Property Get GetPW()
GetPW = strgetPW
End Property

Public 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 Sub

Private 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

[online]

看看这个
没有测试
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 Long

Const BaseKey = 43 'used to encrypt the main key

Const 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 String

Dim Counter As Integer

Dim DayNum As String

Dim DayKey As Integer

Dim RetData As String

Dim Encrypt As String


'if text is empty, return empty

If Text = "" Then

EncryptData = ""

Exit Function

End 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 data

For Counter = 1 To Len(Text)

DoEvents

Encrypt = Trim(Chr((Asc(Mid(Text, Counter, 1)) + DayKey) Mod 256))

RetData = RetData & Encrypt

Next Counter


EncryptData = RetData

End Function


Public Function DecryptData(Text As String) As String

Dim Counter As Integer

Dim DayNum As String

Dim DayKey As Integer

Dim RetData As String

Dim Decrypt As String

Dim DecryptNum As Integer


'get the amount of digits the key is and decrypt the

'key

If Text = "" Then

Exit Function

End If


DayNum = GetKeyLength(Text)

DayKey = Val(DecryptKey(Mid(Text, 2, Val(DayNum))))

'DayKey = DayKey


'Dim test As Variant

'decrypt the rest of the data

For 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 255

If DecryptNum < 0 Then

DecryptNum = 255 + DecryptNum

Else

DecryptNum = DecryptNum Mod 256

End If


Decrypt = Right(Chr(DecryptNum), 1)

RetData = RetData & Decrypt

Next Counter


DecryptData = RetData

End Function


Public Function GetKeyLength(Text As String) As String

Dim KeyLength As Integer

'get the amount of digits the key is and decrypt the

'key

If Text = "" Then

Exit Function

End If


KeyLength = Len(Str(Asc(Mid(Text, 1, 1))))


GetKeyLength = KeyLength

End Function


Private Function EncryptKey(Key As String) As String

'adds the encryption key to the ASCII value of each

'character.


Dim Counter As Integer

Dim 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 = NewKey

End Function


Private Function DecryptKey(Key As String) As String

'subtracts the encryption key from the ASCII value

'of each character.


Dim Counter As Integer

Dim NewKey As String

Dim 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 = NewKey

End Function

[abc10]

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

[abc10]

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

[hlm750908]

一个类 dsEncrypt.cls

Option 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 = EncryptedString

End 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)

[godofwind]

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

[jfx]

有个控件要不要？