vb文件加密解密

❶ 怎样用VB编写一个文件加密程序

字节逐位倒排序加密法是以比特为单位的换位加密方法，用VB实现的具体算法是：
(1) 以二进制模式打开源文件；
(2) 从源文件第I位读取一个字节，假设为字母“A”，得到“A”的ASCII值为65；
(3) 将65转换成八位二进制串为“01000001”；
(4) 将“01000001”按字节逐位倒排序得另一个八位二进制串“10000010”；
(5) 将“10000010”转换成十进制再写回源文件第I位置，完成一个字节的加密；
(6) 重复(2)、(3)、(4)和(5)，直到所有字节加密结束。
为了使程序模块化，我们用函数过程ByteToBin完成将字节型数据转换成二进制串（其实质就是将十进制数转换成八位二进制串）；用函数过程BinToByte将二进制串转换成字节型数据（实质是将八位二进制串转换成十进制数）：用函数过程Reverse将八位二进制串逐位倒排序。具体程序如下：
Function ByteToBin(m As Byte) As String ' 将字节型数据转换成八位二进制字符串
Dim c$
c$ = ""
Do While m <> 0
r = m Mod 2
m = m \ 2
c$ = r & c$
Loop
c$ = Right("00000000" & c$, 8)
ByteToBin = c$
End Function
Function Reverse(m As String) As String ' 将八位二进制字符串颠倒顺序
Dim i%, x$
x = ""
For i = 1 To 8
x = Mid(m, i, 1) & x
Next i
Reverse = x
End Function
Function BinToByte(m As String) As Byte ' 将八位二进制串转换成十进制
Dim x As String * 1, y%, z%
z = 0
For i = 1 To 8
x = Mid(m, i, 1)
y = x * 2 ^ (8 - i)
z = z + y
Next i
BinToByte = z
End Function
Private Sub Command1_Click()
Dim x As Byte, i%, fname$
fname = InputBox("请输入要加密的文件名！注意加上路径名：")
If Dir(fname) = "" Then
MsgBox "文件不存在！"
Exit Sub
End If
Open fname For Binary As #1 ' 以二进制访问模式打开待加悔穗扒密文件
For i = 1 To LOF(1) ' LOF函数是求文件长度的内部函数
Get #1, i, x ' 取出第i个字节
x = BinToByte(Reverse(ByteToBin(x))) ' 这里调用了三个自定义函数
Put #1, i, x ' 将加密后的这个字节写回到文件原位置
Next i
Close
MsgBox "任务完成！"
End Sub
本例可以完成对任意文件的加密与解密，对同一文件作第一次处理为加密，第二次处理为解族搭密。要调试本程序，碧昌可用记事本在C盘根目录下任意建立一个文本文件（假设为文件名为aaa.txt），其中的内容任意（可以包括字母、汉字、数字、回车符、换行符等）。运行本程序后，在输入文件名的对话框中输入文件名（如：“C:\aaa.txt”）后回车，即可完成对文件的加密。文件加密后，可以在记事本中打开该文件查看加密效果。如果想解密，可再次运行该程序并输入相同文件名。

❷ 运用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实现加密解密程序。

这里只给出按钮事件的过程，加密算法（函数）你自己想办法：
设加密算法函数名为encryptxt，解密算法函数名为unencryptxt，不带参数。
加密窗口“生成密文”按钮事件：
Private sub 生成密文_Click()
Frame1.Caption = encryptxt (Text1.text)
End Sub

解密窗口“解密”按钮事件：
Private Sub 解密_Click()
Frame2.Caption = unencryptxt(Rrame1.Caption)
End Sub

❹ VB 字符串加密解密[高分]

就这样了，大概还行
Private Function Encrypt(ByVal StrSource As String) As String '加密
Dim BLowData As Byte
Dim BHigData As Byte
Dim i As Long
Dim k As Integer
Dim StrEncrypt As String
Dim StrChar As String
Dim KeyTemp As String
Dim Key1 As Byte
For k = 1 To 30
KeyTemp = KeyTemp & CStr(Int(Rnd * (9) + 1))
Next
Key1 = CByte(Mid(KeyTemp, 11, 1) & Mid(KeyTemp, 27, 1))
For i = 1 To Len(StrSource)
StrChar = Mid(StrSource, i, 1) '从待加密字符串中取出一个字符
BLowData = AscB(MidB(StrChar, 1, 1)) Xor Key1 '取字符的低字节和Key1进行异或运算
SHigData = AscB(MidB(StrChar, 2, 1)) '取字符的高字节
StrEncrypt = StrEncrypt & ChrB(BLowData) & ChrB(BHigData) '将运算后的数据合成新的字符
Next i
Encrypt = KeyTemp & StrEncrypt
End FunctionPrivate Function Decrypt(ByVal StrSource As String) As String '解密
Dim BLowData As Byte
Dim BHigData As Byte
Dim i As Long
Dim k As Integer
Dim StrDecrypt As String
Dim StrChar As String
Dim KeyTemp As String
Dim Key1 As Byte
KeyTemp = Mid(StrSource, 1, 30)
Key1 = CByte(Mid(KeyTemp, 11, 1) & Mid(KeyTemp, 27, 1))
For i = 31 To Len(StrSource)
StrChar = Mid(StrSource, i, 1) '从待解密字符串中取出一个字符
BLowData = AscB(MidB(StrChar, 1, 1)) Xor Key1 '取字符的低字节和Key1进行异或运算
BHigData = AscB(MidB(StrChar, 2, 1)) '取字符的高字节
StrDecrypt = StrDecrypt & ChrB(BLowData) & ChrB(BHigData) '将运算后的数据合成新的字符
Next i
Decrypt = StrDecryptEnd Function
Private Sub Command2_Click()
MsgBox Decrypt(InputBox(""))
End SubPrivate Sub Command1_Click()
Text1.Text = Encrypt(InputBox(""))
End Sub

❺ VB 加密与解密的程序代码

加密：

PrivateFunction JiaMi(ByVal varPass As String) As String '参数varPass是需要加密的文本内容

Dim varJiaMi As String * 20

Dim varTmp As Double

Dim strJiaMi As String

Dim I

For I = 1 To Len(varPass)

varTmp = AscW(Mid$(varPass, I, 1))

varJiaMi = Str$(((((varTmp * 1.5) / 5.6) * 2.7) * I))

strJiaMi = strJiaMi & varJiaMi

NextI

JiaMi = strJiaMi

EndFunction

解密函数：

PrivateFunction JieMi(ByVal varPass As String) As String '参数varPass是需要解密的密文内容

Dim varReturn As String * 20

Dim varConvert As Double

Dim varFinalPass As String

Dim varKey As Integer

Dim varPasslenth As Long

varPasslenth = Len(varPass)

For I = 1 To varPasslenth / 20

varReturn = Mid(varPass, (I - 1) * 20 + 1, 20)

varConvert = Val(Trim(varReturn))

varConvert = ((((varConvert / 1.5) * 5.6) / 2.7) / I)

varFinalPass = varFinalPass & ChrW(Val(varConvert))

NextI

JieMi = varFinalPass

EndFunction

(5)vb文件加密解密扩展阅读：

注意事项

编写加密程序，将用户输入的一个英文句子加密为加密字符串，然后输出加密字符串。假设句子长度不超过100个字符。

根据给定的句子加密函数原型SentenceEncoding，编写函数SentenceEncoding调用给定的字符加密函数CharEncoding完成句子加密。

然后，编写主程序提示用户输入英文句子，然后调用函数SentenceEncoding对句子加密，最后输出加密后的蔽铅句子。

字符加密规则为大写字母和小写字母均加密为其补码, 我们定义ASCII码值相加为’A’+’Z’即155的两个大写字母互为补码，ASCII码值相加改禅为’a’+’z’即219的两个小写字母互为补码。

空格用@代替,句号以#代替,其它字符用句点代替。

函数原型：

void SentenceEncoding(char *soure,char *code);

功能：对待加密字符串source加密后保存加密字符串到code.

参数：char *soure，指向待加密句子的字符串指针；

char *code 指向加密字符串的字符串指针；

字符加密宏歼好函数代码。

❻ 简单VB.NET加密与解密

Private Function myEncrypt(ByVal Code As String) As String
Dim Result As String = ""

Dim CurrentChar As Char

For i As Integer = 0 To Code.Length - 1

CurrentChar = Code.Substring(i, 1)

Select Case Code.Substring(i, 1)
Case "Z"
Result &= "a"
Case "z"
Result &= "A"
Case Else
Result &= Chr(Asc(CurrentChar) + 1)
End Select
Next
Return Result
End Function

'vb.net 2005 调试通过

❼ 怎样用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写个简单加密/解密程序

'图上的控件,你就照着摆上去,然后再把以下代码拷进去,就OK了
Dim lg As Integer
'加密
Private Sub Command1_Click()
Text2 = ""
Dim a(), b() As String
lg = Len(Text1)
ReDim a(lg), b(lg)
For i = 1 To lg
a(i) = Mid(Text1, i, 1)
b(i) = AscW(a(i)) Xor 4
Text2 = Text2 & ChrW(b(i))
Next
End Sub
'解密
Private Sub Command2_Click()
Text3 = ""
Dim a(), b() As String
lg = Len(Text2)
ReDim a(lg), b(lg)
For i = 1 To lg
a(i) = Mid(Text2, i, 1)
b(i) = AscW(a(i)) Xor 4
Text3 = Text3 & ChrW(b(i))
Next
End Sub

❾ vb 文本的加密解密问题

Private Sub Command1_Click() Open App.Path & "\\aaa.txt" For Output As #1 Print #1, Enc(Text1.Text, 1) Close #1 Debug.Print "加密内容:" & Enc(Text1.Text, 1) MsgBox "加密文件已输出!" End Sub Private Sub Command2_Click() Open App.Path & "\\aaa.txt" For Input As #1 Do While Not EOF(1) Line Input #1, tmp Text1.Text = deEnc(tmp, 1) Debug.Print "解密:" & tmp & "为:" & deEnc(tmp, 1) Loop Close #1 End Sub Function Enc(ByVal Str1 As String, ByVal EncCode As Long) As String ' EncCode为加密密码,你可以自己修改 '日曜星君原创作品,QQ:575837484 Dim strEnc As String For i = 1 To Len(Str1) strEnc = strEnc & Chr(Asc(Mid(Str1, i, 1)) + EncCode) Next i Enc = strEnc End Function Function deEnc(ByVal Str1 As String, ByVal deEncCode As Long) As String ' EncCode为解密密码,必须和加密密码一样,否则是乱码! '日曜星君原创作品,QQ:575837484 Dim strDeEnc As String For i = 1 To Len(Str1) strDeEnc = strDeEnc & Chr(Asc(Mid(Str1, i, 1)) - deEncCode) Next i deEnc = strDeEnc End Functio

❿ 使用VB作出加密，解密并显示密钥

'这是我以前回答别人提问时写的，添加三个文本框，一个按钮。text3文本框中输入要加密的
'文本，在text2中是加密的文本，在text1中是对加密的文本解密。加密和解密用同一个
'过程'Private Function JiaMi(a As String) As String

Private Sub Command1_Click()
Dim a As String
Dim b As String
a = Text3
For i = 1 To Len(a)
b = b & JiaMi(Mid(a, i, 1))
Next i
Text2 = b
a = Text2
b = ""
For i = 1 To Len(a)
b = b & JiaMi(Mid(a, i, 1))
Next i
Text1 = b
End Sub
Private Function JiaMi(a As String) As String
Dim IntAsc As Integer
IntAsc = Asc(a)
If IntAsc Mod 2 Then
IntAsc = IntAsc + 47
If IntAsc > 126 Then IntAsc = IntAsc - 47
Else
IntAsc = IntAsc - 47
If IntAsc < 33 Then IntAsc = IntAsc + 47
End If
JiaMi = Chr(IntAsc)
End Function