vb加密中文
‘壹’ vb MD5 加密汉字和标准的不一样.
很可能是你的原字符串的编码不和标准的一样
‘贰’ 运用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 = ""
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 = ""
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给文件夹加密
1、由于采用二进制读取文件的方式，因此加密时一般可以不考虑文件类型。
2、这里只进行一次异或运算，如有需要可以进行多次异或运算。
3、此加密算法速度快，当然加密强度也低 ；
参考代码如下：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
'-----------------------------------------------------------------------
'函数说明： 使用异或运算加密文件（可加密大部分文件）
'参数说明： key - 密钥
' fileName - 普通文件名，
' encryptFileName - 加密后的文件名
'返回值： true - 成功，false - 失败
'-----------------------------------------------------------------------
Private Function XOR_Encrypt(key As Integer, fileName As String, encryptFileName As String) As Boolean
On Error GoTo errHandler
Dim inputFileNo As Integer
Dim fileBytes() As Byte
Dim length As Long
XOR_Encrypt = False
'打开文件并保存在二进制数组中
inputFileNo = FreeFile
Open fileName For Binary As #inputFileNo
length = LOF(inputFileNo)
If length = 0 Then
MsgBox "退出加密：文件内容为空！", vbInformation, "提示"
Exit Function
End If
ReDim fileBytes(length - 1) As Byte
Get inputFileNo, , fileBytes()
Close #inputFileNo
'将该二进制数组进行异或加密
Dim i As Long
For i = LBound(fileBytes) To UBound(fileBytes)
fileBytes(i) = fileBytes(i) Xor key
Next
'将异或加密后的二进制数组保存在新的文件中
Dim outputFileNo As Integer
outputFileNo = FreeFile
Open encryptFileName For Binary As #outputFileNo
Put outputFileNo, , fileBytes
Close #outputFileNo
XOR_Encrypt = True
errHandler:
If Err.Number Then
MsgBox "加密过程中出错：" & Err.Description, vbCritical, "错误"
XOR_Encrypt = False
Resume Next
End If
End Function
‘肆’ 怎样用VB给文件夹进行密码加密
文件或文件夹的加密、解密
'此方法对 WinXP 系统有效，Win98 没试验过。小心：不能用于系统文件或文件夹，否则会使系统瘫痪。
'加密：利用 API 函数在文件或文件夹名称末尾添上字符“..\”。比如，将文件夹“MyPath”更名为“MyPath..\”，在我的电脑中显示的名称就是“MyPath.”。系统会无法识别，此文件或文件夹就无法打开和修改，也无法删除。着名的病毒 Autorun 就是玩的这个小把戏。
'解密：去掉文件或文件夹名称末尾的字符“..\”
'将以下代码复制到 VB 的窗体代码窗口即可
'例子需控件：Command1、Command2、Text1，均采用默认属性设置
Private Const MAX_PATH = 260
Private Type FileTime ' 8 Bytes
LTime As Long
HTime As Long
End Type
Private Type Win32_Find_Data
dwFileAttributes As Long
ftCreationTime As FileTime
ftLastAccessTime As FileTime
ftLastWriteTime As FileTime
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cNameFile As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpNameFile As String, lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Sub Form_Load()
Text1.Text = "C:\MyPath"
Command1.Caption = "解密": Command2.Caption = "加密"
Me.Caption = "目录或文件的加解密"
End Sub
Private Sub Command1_Click()
Call SetPathName(False) '解密
End Sub
Private Sub Command2_Click()
Call SetPathName(True) '加密
End Sub
Private Sub SetPathName(SetMi As Boolean)
Dim nName As String, NewName As String, nSort As String, nCap As String, dl As Long
nName = Trim(Text1.Text)
If Right(nName, 3) = "..\" Then nName = Left(nName, Len(nName) - 3)
If Right(nName, 1) = "\" Then nName = Left(nName, Len(nName) - 1)
If SetMi Then
NewName = nName & "..\"
Else
NewName = nName
nName = nName & "..\"
End If
If SetMi Then nCap = "加密" Else nCap = "解密"
nSort = GetShortName(nName) '转变其中的 ..\
If nSort = "" Then
MsgBox "文件没有找到：" & vbCrLf & nName, vbCritical, nCap
Exit Sub
End If
If MoveFileEx(nSort, NewName, 0) = 0 Then Exit Sub '文件更名：非零表示成功，支持只读文件
MsgBox nCap & "成功：" & vbCrLf & nName, vbInformation, nCap
End Sub
Public Function GetShortName(F As String, Optional ShortAll As Boolean) As String
'转变为短文件名，如果目录或文件不存在就返回空。可用于判断某目录或文件是否存在
'不能直接用 API 函数 GetShortPathName， 因它不支持 ..\
'ShortAll=T 表示全部转变为短名称，否则只转变其中的点点杠“..\”
Dim FondID As Long, ID1 As Long, S As Long, nPath As String
Dim nF As String, InfoF As Win32_Find_Data, qF As String, hF As String
Dim nName As String, nName1 As String
nF = F
Do
S = InStr(nF, "..\")
If S = 0 Then Exit Do
qF = Left(nF, S + 2): hF = Mid(nF, S + 3) '分为前后两部分
CutPathName qF, nPath, nName
nName = LCase(nName)
qF = nPath & "\" & "*."
FondID = FindFirstFile(qF, InfoF) '-1表示失败。查找所有文件（夹）
ID1 = FondID
Do
If FondID = Find_Err Or ID1 = 0 Then GoTo Exit1 '没有找到符合条件的条目
nName1 = LCase(CutChr0(InfoF.cNameFile)) '文件（夹）名称
If nName1 & ".\" = nName Then
nName1 = CutChr0(InfoF.cAlternate) '用短文件名代替
If hF = "" Then nF = nPath & "\" & nName1 Else nF = nPath & "\" & nName1 & "\" & hF
Exit Do
End If
ID1 = FindNextFile(FondID, InfoF) '查找下一个，0表示失败
Loop
FindClose FondID
Loop
Exit1:
FindClose FondID
S = MAX_PATH: nName = String(S, vbNullChar)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数，0表示失败
If ID1 = 0 Then Exit Function
If ShortAll Then
If ID1 > S Then
S = ID1: nName = String(S, vbNullChar)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数
End If
GetShortName = CutChr0(nName)
Else
GetShortName = nF
End If
End Function
Public Sub CutPathName(ByVal F As String, nPath As String, nName As String)
Dim I As Long, LenS As Long
LenS = Len(F)
For I = LenS - 1 To 2 Step -1
If Mid(F, I, 1) = "\" Then
nPath = Left(F, I - 1): nName = Mid(F, I + 1)
GoTo Exit1
End If
Next
nPath = F: nName = ""
Exit1:
If Right(nPath, 2) = ".." Then
nPath = nPath & "\"
Else
If Right(nPath, 1) = "\" Then nPath = Left(nPath, Len(nPath) - 1)
End If
If Right(nName, 1) = "\" And Right(nName, 3) <> "..\" Then nName = Left(nName, Len(nName) - 1)
End Sub
Private Function CutChr0(xx As String) As String
Dim S As Long
S = InStr(xx, vbNullChar)
If S > 0 Then CutChr0 = Left(xx, S - 1) Else CutChr0 = xx
End Function
'参考资料见下
‘伍’ vb中如何对字符串进行加密和解密（有汉字的）
源程序如下：
Public Function StringEnDeCodecn(strSource As String, MA) As String
'该函数只对中西文起到加密作用
'参数为：源文件，密码
On Error GoTo ErrEnDeCode
Dim X As Single
Dim CHARNUM As Long, RANDOMINTEGER As Integer
Dim SINGLECHAR As String * 1
Dim strTmp As String
If MA < 0 Then
MA = MA * (-1)
End If
X = Rnd(-MA)
For i = 1 To Len(strSource) Step 1 '取单字节内容
SINGLECHAR = Mid(strSource, i, 1)
CHARNUM = Asc(SINGLECHAR)
g: RANDOMINTEGER = Int(127 * Rnd)
If RANDOMINTEGER < 30 Or RANDOMINTEGER > 100 Then GoTo g
CHARNUM = CHARNUM Xor RANDOMINTEGER
strTmp = strTmp & Chr(CHARNUM)
Next i
StringEnDeCodecn = strTmp
Exit Function
ErrEnDeCode:
StringEnDeCodecn = ""
MsgBox Err.Number & "\" & Err.Description
End Function
使用方法：
tmp=stringEnDecn("中华人民共和国",75)
如果要解密的话，只须键入以下语句：
tmp1=stringendecn(tmp,75)
‘陆’ vb编程，设计一个文本加密程序。输入一个字符串，按照以下规律加密“
'运行效果如上图，代码如下所示：
'判断中我将大小写字母均按规则进行了转换。
'原创，亲测可用，转发请说明出处。
PrivateSubCommand1_Click()
Dima,bAsString
a=Text1.Text
DimiAsInteger
i=Len(a)
Dimarr()AsString
ReDimarr(1Toi)
DimjAsInteger
Forj=1Toi
b=Mid(a,j,1)
IfAsc(b)>=97AndAsc(b)<=118Then
arr(j)=Chr(Asc(b)+4)
EndIf
IfAsc(b)=119Then
arr(j)="a"
EndIf
IfAsc(b)=120Then
arr(j)="b"
EndIf
IfAsc(b)=121Then
arr(j)="c"
EndIf
IfAsc(b)=122Then
arr(j)="d"
EndIf
IfAsc(b)>=65AndAsc(b)<=86Then
arr(j)=Chr(Asc(b)+4)
EndIf
IfAsc(b)=87Then
arr(j)="A"
EndIf
IfAsc(b)=88Then
arr(j)="B"
EndIf
IfAsc(b)=89Then
arr(j)="C"
EndIf
IfAsc(b)=90Then
arr(j)="D"
EndIf
IfAsc(b)<65OrAsc(b)>122Or(Asc(b)>90AndAsc(b)<97)Then
arr(j)=b
EndIf
Nextj
Text2.Text=Join(arr,"")
EndSub
‘柒’ 用VB如何给文件加密
这个比较麻烦的。
给文件加密，我还是建议您选择专业的文件加密软件。
超级加密3000拥有高强度加密算法,有效保障数据安全!
建议您再加密文件的时候可以试试。