vb代码加密变解密（vb源代码加密）

本篇文章给大家谈谈vb代码加密变解密，以及vb源代码加密对应的知识点，希望对各位有所帮助，不要忘了收藏本站喔。

本文目录一览：

• 1、运用VB对文字进行加密解密
• 2、VB加密解密，急！！
• 3、VB 实现字符串加密 解密
• 4、用vb编一个加密解密的程序

运用VB对文字进行加密解密

'这是我从网上找到的一段加密解密的代码，很不错，应该符合要求。

'文本框的multiline属性是用来设置是否可以接受多行文本，只能在窗体上手工设置。

'文本框的scrollbars属性是用来设置是否有垂直和水平滚动条的，也只能在窗体上手工设置。

'keyAscii不清楚是作什么用的。

'两个StrConv函数用的太好了，我没想到能处理的这么简单。

Option Explicit

Dim key() As Byte

Sub initkey() '这里为密匙，建议定义的复杂些，我这里仅仅是个示例

ReDim key(9)

key(0) = 12

key(1) = 43

key(2) = 53

key(3) = 67

key(4) = 78

key(5) = 82

key(6) = 91

key(7) = 245

key(8) = 218

key(9) = 190

End Sub

Function Pass_Encode(ByVal s As String) As String '加密

On Error GoTo myerr

initkey

Dim buff() As Byte

buff = StrConv(s, vbFromUnicode)

Dim i As Long, j As Long

Dim k As Long

k = UBound(key) + 1

For i = 0 To UBound(buff)

j = i Mod k

buff(i) = buff(i) Xor key(j)

Next

Dim mstr As String

mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Dim outstr As String

Dim temps As String

For i = 0 To UBound(buff)

k = buff(i) \ Len(mstr)

j = buff(i) Mod Len(mstr)

temps = Mid(mstr, j + 1, 1) + Mid(mstr, k + 1, 1)

outstr = outstr + temps

Next

Pass_Encode = outstr

Exit Function

myerr:

Pass_Encode = ""

End Function

Function Pass_Decode(ByVal s As String) As String '解密

On Error GoTo myerr

initkey

Dim i As Long, j As Long

Dim k As Long, n As Long

Dim mstr As String

mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Dim outstr As String

Dim temps As String

If Len(s) Mod 2 = 1 Then

Pass_Decode = ""

Exit Function

End If

Dim t1 As String

Dim t2 As String

Dim buff() As Byte

Dim m As Long

m = 0

For i = 1 To Len(s) Step 2

t1 = Mid(s, i, 1)

t2 = Mid(s, i + 1, 1)

j = InStr(1, mstr, t1)

k = InStr(1, mstr, t2)

n = j - 1 + (k - 1) * Len(mstr)

ReDim Preserve buff(m)

buff(m) = n

m = m + 1

Next

k = UBound(key) + 1

For i = 0 To UBound(buff)

j = i Mod k

buff(i) = buff(i) Xor key(j)

Next

Pass_Decode = StrConv(buff, vbUnicode)

Exit Function

myerr:

Pass_Decode = ""

End Function

Private Sub Command1_Click()

Text2.Text = Pass_Encode(Text1.Text)

Text3.Text = Pass_Decode(Text2.Text)

End Sub

VB加密解密，急！！

%

'----加密/解密 函数------

%

%

dim sBASE_64_CHARACTERS,varchar,varasc

dim len1

dim i

dim m3

sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

sBASE_64_CHARACTERS = strUnicode2Ansi(sBASE_64_CHARACTERS)

Function strUnicodeLen(asContents)

'计算unicode字符串的Ansi编码的长度

asContents1="a"asContents

len1=len(asContents1)

k=0

for i=1 to len1

asc1=asc(mid(asContents1,i,1))

if asc10 then asc1=65536+asc1

if asc1255 then

k=k+2

else

k=k+1

end if

next

strUnicodeLen=k-1

End Function

Function strUnicode2Ansi(asContents)

'将Unicode编码的字符串，转换成Ansi编码的字符串

strUnicode2Ansi=""

len1=len(asContents)

for i=1 to len1

varchar=mid(asContents,i,1)

varasc=asc(varchar)

if varasc0 then varasc=varasc+65536

if varasc255 then

varHex=Hex(varasc)

varlow=left(varHex,2)

varhigh=right(varHex,2)

strUnicode2Ansi=strUnicode2Ansi chrb("H" varlow ) chrb("H" varhigh )

else

strUnicode2Ansi=strUnicode2Ansi chrb(varasc)

end if

next

End function

Function strAnsi2Unicode(asContents)

'将Ansi编码的字符串，转换成Unicode编码的字符串

strAnsi2Unicode = ""

len1=lenb(asContents)

if len1=0 then exit function

for i=1 to len1

varchar=midb(asContents,i,1)

varasc=ascb(varchar)

if varasc 127 then

strAnsi2Unicode = strAnsi2Unicode chr(ascw(midb(asContents,i+1,1) varchar))

i=i+1

else

strAnsi2Unicode = strAnsi2Unicode chr(varasc)

end if

next

End function

Function Base64encode(asContents)

'将Ansi编码的字符串进行Base64编码

'asContents应当是ANSI编码的字符串（二进制的字符串也可以）

Dim lnPosition

Dim lsResult

Dim Char1

Dim Char2

Dim Char3

Dim Char4

Dim Byte1

Dim Byte2

Dim Byte3

Dim SaveBits1

Dim SaveBits2

Dim lsGroupBinary

Dim lsGroup64

Dim m4,len1,len2

len1=Lenb(asContents)

if len11 then

Base64encode=""

exit Function

end if

m3=Len1 Mod 3

If M3 0 Then asContents = asContents String(3-M3, chrb(0))

IF m3 0 THEN

len1=len1+(3-m3)

len2=len1-3

else

len2=len1

end if

lsResult = ""

For lnPosition = 1 To len2 Step 3

lsGroup64 = ""

lsGroupBinary = Midb(asContents, lnPosition, 3)

Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3

Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15

Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))

Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)

Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And HFF) + 1, 1)

Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And HFF) + 1, 1)

Char4 = Midb(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)

lsGroup64 = Char1 Char2 Char3 Char4

lsResult = lsResult lsGroup64

Next

if M3 0 then

lsGroup64 = ""

lsGroupBinary = Midb(asContents, len2+1, 3)

Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3

Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15

Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))

Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)

Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And HFF) + 1, 1)

Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And HFF) + 1, 1)

if M3=1 then

lsGroup64 = Char1 Char2 ChrB(61) ChrB(61)

else

lsGroup64 = Char1 Char2 Char3 ChrB(61)

end if

lsResult = lsResult lsGroup64

end if

Base64encode = lsResult

End Function

Function Base64decode(asContents)

'将Base64编码字符串转换成Ansi编码的字符串

'asContents应当也是ANSI编码的字符串（二进制的字符串也可以）

Dim lsResult

Dim lnPosition

Dim lsGroup64, lsGroupBinary

Dim Char1, Char2, Char3, Char4

Dim Byte1, Byte2, Byte3

Dim M4,len1,len2

len1= Lenb(asContents)

M4 = len1 Mod 4

if len1 1 or M4 0 then

Base64decode = ""

exit Function

end if

if midb(asContents, len1, 1) = chrb(61) then m4=3

if midb(asContents, len1-1, 1) = chrb(61) then m4=2

if m4 = 0 then

len2=len1

else

len2=len1-4

end if

For lnPosition = 1 To Len2 Step 4

lsGroupBinary = ""

lsGroup64 = Midb(asContents, lnPosition, 4)

Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1

Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1

Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1

Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1

Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And HFF)

Byte2 = lsGroupBinary Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And HFF)

Byte3 = Chrb((((Char3 And 3) * 64) And HFF) Or (Char4 And 63))

lsGroupBinary = Byte1 Byte2 Byte3

lsResult = lsResult lsGroupBinary

Next

'处理最后剩余的几个字符

if M4 0 then

lsGroupBinary = ""

lsGroup64 = Midb(asContents, len2+1, m4) chrB(65) 'chr(65)=A，转换成值为0

if M4=2 then '补足4位，是为了便于计算

lsGroup64 = lsGroup64 chrB(65)

end if

Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1

Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1

Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1

Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1

Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And HFF)

Byte2 = lsGroupBinary Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And HFF)

Byte3 = Chrb((((Char3 And 3) * 64) And HFF) Or (Char4 And 63))

if M4=2 then

lsGroupBinary = Byte1

elseif M4=3 then

lsGroupBinary = Byte1 Byte2

end if

lsResult = lsResult lsGroupBinary

end if

Base64decode = lsResult

End Function

'------------------------------------------------------------------

Function Base64EncodeStr(tpStr)

Base64EncodeStr=strAnsi2Unicode(Base64encode(strUnicode2Ansi(tpStr)))

End Function

Function Base64DecodeStr(tpStr)

Base64DecodeStr=strAnsi2Unicode(Base64decode(strUnicode2Ansi(tpStr)))

End Function

%

%

'可用于加密一串地址,多个字符串

A_Key=split("96,44,63,80",",") '定义密钥

'*********加密的过程*********

Function EnCrypt(m)

Dim strChar,iKeyChar,iStringChar,I

k=0

for I = 1 to Len(m)

iKeyChar =Cint(A_Key(k))

iStringChar = Asc(mid(m,I,1)) '获取字符的ASCII码值

iCryptChar = iKeyChar Xor iStringChar '进行异或运算

'对密钥进行移位运算

If k3 Then

k=k+1

Else

k=0

End If

c = c Chr(iCryptChar)

next

EnCrypt = c

End Function

'*********解密的过程*********

Function DeCrypt(c)

Dim strChar, iKeyChar, iStringChar, I

k=0

for I = 1 to Len(c)

iKeyChar =Cint(A_Key(k))

iStringChar = Asc(mid(c,I,1))

iDeCryptChar = iKeyChar Xor iStringChar '进行异或运算

'对密钥进行移位运算

If k3 Then

k=k+1

Else

k=0

End If

strDecrypted = strDecrypted Chr(iDeCryptChar)

next

DeCrypt = strDecrypted

End Function

'中文 可以！但要将所有 Asc() 函数换成 AscW() 函数, Chr() 函数换成 ChrW() 函数！

%

%

'-----------------------------------------------------------------

'简单加密解密

'加密：

'适用于任何字符，包括空格和url冲突的"""?""%"汉字等符号

'简单加密，可以改造成移位加密，比如每个字符asc码值增加或减少一个数字

'可以改造成移位随机加密。

'比如每个字符前有一个随机数字，表示该字符asc码值增加或减少这个随机数字

'-----------------------------------------------------------------

Function Smp_Encode(x) '加密

for i=1 to len(x)

TempNum=hex(asc(mid(x,i,1)))

if len(TempNum)=4 then

Smp_Encode=Smp_Encode cstr(TempNum)

else

Smp_Encode=Smp_Encode "00" cstr(TempNum)

end if

next

End Function

Function Smp_Decode(x) '解密

for i=1 to len(x) step 4

Smp_Decode=Smp_Decode chr(int("H" mid(x,i,4)))

next

End Function

%

%

Function S_Encode(str) '加密字符串

'str = EnCrypt(str)

'str = Base64EncodeStr(str)

str = Smp_Encode(str)

S_Encode = str

End Function

Function S_Decode(str) '解密字符串

'str = DeCrypt(str)

'str = Base64DecodeStr(str)

str = Smp_Decode(str)

S_Decode = str

End Function

%

%

Dim theFStr,theEStr,theLStr,IfReal

theFStr = "#$%'()*+,.-_/:;=?@[\\]^`{|}~%中文" '原始字符串

theEStr = Str_Encode(theFStr) '加密字符串

theLStr = Str_Decode(theEStr) '还原字符串

If theFStr=theLStr Then

IfReal = True

Else

IfReal = False

End If

Response.Write "加密前为:" theFStr "BR"VbCrlf

Response.Write "加密前字符长度:" Len(theFStr) "BRBR"

Response.Write "加密后为:" theEStr "BR"VbCrlf

Response.Write "加密后的字符长度:" Len(theEStr) "BRBR"

Response.Write "解密(还原)后为:" theLStr "BR"VbCrlf

Response.Write "前后字符是否相等:" IfReal "BR"VbCrlf

%

VB 实现字符串加密 解密

'如果是将text1中每个字符的asc码值转化为16进制实现加密解密可以这样：复制粘贴下段代码

'加密数据

Private Sub Command1_Click()

Text2.Tag = "" '清空text2.tag用来存储加密后数据

Text2.Text = "" '清空text2用来显示加密后数据

For i = 1 To Len(Text1.Text) '将text1中每个字符的asc码值转化为十六进制以软回车chr(13)分隔并存储在text2.tag中

Text2.Tag = Text2.Tag Hex(Asc(Mid(Text1.Text, i, 1))) Chr(13) '

Next

Text2.Text = Text2.Tag '显示加密后数据

End Sub

'解密数据

Private Sub Command2_Click()

Text1.Tag = ""

Text1.Text = ""

Dim b() As String '定义数组用来存储由text1中每个字符转化来的十六进制数

b = Split(Text2.Text, Chr(13)) '以软回车符chr(13)分隔text2中文本并存储在数组b中

For i = 0 To UBound(b) '将text2中每个十六进制数转化为十进制的asc码值后转化为字符

Text1.Tag = Text1.Tag Chr(Val("h" b(i)))

Next

Text1.Text = Text1.Tag '显示原始数据

End Sub

用vb编一个加密解密的程序

在窗体上至少添加文件控件：Drive控件，Dir控件，File控件，以及Command控件，每次用Xor加密解密后，在文件名加上前缀X-，另外保存

其他控件你可以添加，用来装饰，比如Label，用做提示

■这已经是详细完整的程序了，窗体添加控件你自己应该会吧？添加后，把下面内容复制到代码窗口就可以了■

Private Sub Command1_Click()

Dim oldFile As String, newfile As String, theByte As Byte

If File1.FileName = "" Then MsgBox "请选择需要加密或解密的文件！": Exit Sub

oldFile = Dir1.Path "\" File1.FileName

newfile = Dir1.Path "\X-" File1.FileName

Open oldFile For Binary As #1 Len = 1

Open newfile For Binary As #2

Do

Get #1, , theByte

theByte = 7 Xor theByte

Put #2, , theByte

Loop Until EOF(1)

Close #1

Close #2

MsgBox "加密或解密后的文件存放在“" newfile "”中！"

File1.Refresh

End Sub

Private Sub Dir1_Change()

File1.Path = Dir1.Path

End Sub

Private Sub Drive1_Change()

Dir1.Path = Drive1.Drive

End Sub

Private Sub Form_Load()

File1.Pattern = "*.txt" '只列出txt文本文件，如果要列出全部文件，改成*.*

Command1.Caption = "加密解密"

End Sub

vb代码加密变解密的介绍就聊到这里吧，感谢你花时间阅读本站内容，更多关于vb源代码加密、vb代码加密变解密的信息别忘了在本站进行查找喔。