您所在位置：主题：[原创]VB文字加密工具源码
孙瑞
[专家分：590] 发布于 2010-07-23 17:53:00
论坛难得有原创贴，大多是问问题的，现在发一个，支持一下论坛。
Dim i, ascii, co1, co2, myao As Long '计数;myao为密钥的意思
Dim part1, part2, part3 As String
Dim strs() As String
Private Sub Command2_Click()
On Error Resume Next
If Text3 <> "" And num(Text3) = False Then
MsgBox "含有非数字字符！"
Text3 = ""
Text3.SetFocus
ElseIf Text3 = "" Then
Text3 = "99"
myao = 99
End If
myao = Val(Text3)
cleardate
If Text2 = "" Then
MsgBox "未输入密文！"
Exit Sub
Else
End If
'初始化
Text1 = ""
strs = Split(Text2, "#")
For i = 0 To UBound(strs)
co1 = Val(strs(i))
co2 = (co1 - myao) / 2
part3 = part3 & Chr(co2)
Next i
Text1 = "原文如下：" & Chr(13) & Chr(10) & part3
'clear data
cleardate
End Sub
Private Sub Command3_Click()
On Error Resume Next
If Text3 <> "" And num(Text3) = False Then
MsgBox "含有非数字字符！"
Text3 = ""
Text3.SetFocus
ElseIf Text3 = "" Then
Text3 = "99"
myao = 99
End If
If Text1 = "" Then
MsgBox "请填写明文！"
Else
Text2 = decode(Text1)
End If
End Sub
Function decode(strings)
On Error Resume Next
For i = 1 To Len(strings) - 1
part1 = Mid(strings, i, 1)
ascii = Asc(part1)
co1 = ascii * 2 + myao
part3 = part3 & co1 & "#"
Next i
part1 = Mid(strings, Len(strings), 1)
ascii = Asc(part1)
co1 = ascii * 2 + myao
part3 = part3 & co1
'over code of make it
co1 = 0
part1 = "": part2 = ""
decode = part3
part3 = ""
End Function
Function cleardate()
part1 = "": part2 = "": part3 = ""
ascii = 0: c01 = 0: co2 = 0
End Function
Private Sub Form_Load()
On Error Resume Next
myao = 99
MsgBox "系统已加载原始密钥，需要更换请另行设定！"
End Sub
Function num(lines)
If IsNumeric(lines) = True Then
num = True
Else
num = False
End If
End Function
---------------------------------------
曾经有人说，论坛随便一个人都比你厉害，那么，在论坛这样的不景气情况下（原来繁荣时一天的帖子可以超过三四十个），希望这个帖子可以激起一点波澜。毕竟，这个程序源码太简单了。
控件说明：
Frame1,Caption:控制区
Frame2,Caption:原文
Frame3,Caption:密文
Command1，退出
Command2，解码
Text1(用来显示明文)
Text2(用来显示密文)
Text3(输入密钥文本框)
Command3，加密
Label1,Caption:密钥：
Label2,Caption:密钥须为大于0的小于1000000的整数
----------------------------------------
完整的程序就是这样了！谢谢大家！
Dim i, ascii, co1, co2, myao As Long '计数;myao为密钥的意思
Dim part1, part2, part3 As String
Dim strs() As String
Private Sub Command2_Click()
On Error Resume Next
If Text3 <> "" And num(Text3) = False Then
MsgBox "含有非数字字符！"
Text3 = ""
Text3.SetFocus
ElseIf Text3 = "" Then
Text3 = "99"
myao = 99
End If
myao = Val(Text3)
cleardate
If Text2 = "" Then
MsgBox "未输入密文！"
Exit Sub
Else
End If
'初始化
Text1 = ""
strs = Split(Text2, "#")
For i = 0 To UBound(strs)
co1 = Val(strs(i))
co2 = (co1 - myao) / 2
part3 = part3 & Chr(co2)
Next i
Text1 = "原文如下：" & Chr(13) & Chr(10) & part3
'clear data
cleardate
End Sub
Private Sub Command3_Click()
On Error Resume Next
If Text3 <> "" And num(Text3) = False Then
MsgBox "含有非数字字符！"
Text3 = ""
Text3.SetFocus
ElseIf Text3 = "" Then
Text3 = "99"
myao = 99
End If
If Text1 = "" Then
MsgBox "请填写明文！"
Else
Text2 = decode(Text1)
End If
End Sub
Function decode(strings)
On Error Resume Next
For i = 1 To Len(strings) - 1
part1 = Mid(strings, i, 1)
ascii = Asc(part1)
co1 = ascii * 2 + myao
part3 = part3 & co1 & "#"
Next i
part1 = Mid(strings, Len(strings), 1)
ascii = Asc(part1)
co1 = ascii * 2 + myao
part3 = part3 & co1
'over code of make it
co1 = 0
part1 = "": part2 = ""
decode = part3
part3 = ""
End Function
Function cleardate()
part1 = "": part2 = "": part3 = ""
ascii = 0: c01 = 0: co2 = 0
End Function
Private Sub Form_Load()
On Error Resume Next
myao = 99
MsgBox "系统已加载原始密钥，需要更换请另行设定！"
End Sub
Function num(lines)
If IsNumeric(lines) = True Then
num = True
Else
num = False
End If
End Function
---------------------------------------
曾经有人说，论坛随便一个人都比你厉害，那么，在论坛这样的不景气情况下（原来繁荣时一天的帖子可以超过三四十个），希望这个帖子可以激起一点波澜。毕竟，这个程序源码太简单了。
控件说明：
Frame1,Caption:控制区
Frame2,Caption:原文
Frame3,Caption:密文
Command1，退出
Command2，解码
Text1(用来显示明文)
Text2(用来显示密文)
Text3(输入密钥文本框)
Command3，加密
Label1,Caption:密钥：
Label2,Caption:密钥须为大于0的小于1000000的整数
----------------------------------------
完整的程序就是这样了！谢谢大家！