1请问如何用VB编写加密 文本(txt) 功能的ExE?
2能否将加密功能扩展至加密所有文件
ljl88900 谢谢 但用 visual basic 具体怎么操作(我很菜) 请不吝赐教
VB代码求助
答案:3 悬赏:80 手机版
解决时间 2021-02-06 15:46
- 提问者网友：沉默的哀伤
- 2021-02-05 20:58
最佳答案
- 五星知识达人网友：几近狂妄
- 2021-02-05 21:17
'dsEncrypt.cls
'说明：
' 各种通用文本文件加密算法
'日期：1999.05.13更新
'
'
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
'另一种数据加、解密方法
Public Function Encode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long
TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条
For vChar = 1 To TempCount
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 '默认深度
If Depth > 254 Then Depth = 254
TempAsc = TempAsc + Depth
If TempAsc > 255 Then TempAsc = TempAsc - 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar
frmEncrypt.ProgressBar1.Visible = False '隐藏进程条
Encode = NewData
End Function
Public Function Decode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long
TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条
For vChar = 1 To TempCount
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 '默认深度
If Depth > 254 Then Depth = 254
TempAsc = TempAsc - Depth
If TempAsc < 0 Then TempAsc = TempAsc + 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar
frmEncrypt.ProgressBar1.Visible = False '隐藏进程条
Decode = NewData
End Function
'加入RLE压缩算法（压缩重复字符）
Public Function RLEDecode(InputString As String) As String
Dim RLEString As String
Dim TextString As String
Dim x As Integer
For x = 1 To Len(InputString)
ThisChar = Mid$(InputString, x, 1)
If ThisChar = "~" Then
TextString = TextString & String$(Asc(Mid$(InputString, x + 1, 1)), PrevChar)
x = x + 1
Else
TextString = TextString & ThisChar
End If
PrevChar = ThisChar
Next x
RLEDecode = TextString
End Function
Public Function RLEEncode(InputString As String) As String
Dim LastChar As String
Dim ThisChar As String
Dim RLEString As String
Dim DupeChar As String
Dim x As Integer
Dim RepeatCount As Integer
RepeatCount = 0
For x = 1 To Len(InputString)
ThisChar = Mid$(InputString, x, 1)
If LastChar = ThisChar Then
'If there is only 1 repeating (like the e in Cheese)
'then don't encode
'because it will take 1 extra byte
If Mid$(InputString$, x + 1, 1) <> ThisChar And _
RepeatCount = 0 Then
RLEString = RLEString & ThisChar
LastChar = ThisChar
Else
RepeatCount = RepeatCount + 1
'We can only encode up to 254 repeats after that
'we have to start the new sequence again
If RepeatCount = 254 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
LastChar = ""
End If
End If
Else
If RepeatCount > 0 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
End If
RLEString = RLEString & ThisChar
LastChar = ThisChar
End If
Next x
'If the last chars in string are repeats
If RepeatCount > 0 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
End If
RLEEncode = RLEString
End Function
'调用举例：
Private MydsEncrypt As dsEncryp
dim Mtext as string
Mtext=MydsEncrypt.Encode(Mtext, 1)'加密后的内容写回原字符串中
'说明：
' 各种通用文本文件加密算法
'日期：1999.05.13更新
'
'
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
'另一种数据加、解密方法
Public Function Encode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long
TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条
For vChar = 1 To TempCount
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 '默认深度
If Depth > 254 Then Depth = 254
TempAsc = TempAsc + Depth
If TempAsc > 255 Then TempAsc = TempAsc - 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar
frmEncrypt.ProgressBar1.Visible = False '隐藏进程条
Encode = NewData
End Function
Public Function Decode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Long
Dim TempCount As Long
TempCount = Len(Data) '设置进程条来显示进度长度
frmEncrypt.ProgressBar1.Max = TempCount
frmEncrypt.ProgressBar1.Visible = True '显示进程条
For vChar = 1 To TempCount
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 '默认深度
If Depth > 254 Then Depth = 254
TempAsc = TempAsc - Depth
If TempAsc < 0 Then TempAsc = TempAsc + 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
frmEncrypt.ProgressBar1.Value = vChar '进程条当前值改变
Next vChar
frmEncrypt.ProgressBar1.Visible = False '隐藏进程条
Decode = NewData
End Function
'加入RLE压缩算法（压缩重复字符）
Public Function RLEDecode(InputString As String) As String
Dim RLEString As String
Dim TextString As String
Dim x As Integer
For x = 1 To Len(InputString)
ThisChar = Mid$(InputString, x, 1)
If ThisChar = "~" Then
TextString = TextString & String$(Asc(Mid$(InputString, x + 1, 1)), PrevChar)
x = x + 1
Else
TextString = TextString & ThisChar
End If
PrevChar = ThisChar
Next x
RLEDecode = TextString
End Function
Public Function RLEEncode(InputString As String) As String
Dim LastChar As String
Dim ThisChar As String
Dim RLEString As String
Dim DupeChar As String
Dim x As Integer
Dim RepeatCount As Integer
RepeatCount = 0
For x = 1 To Len(InputString)
ThisChar = Mid$(InputString, x, 1)
If LastChar = ThisChar Then
'If there is only 1 repeating (like the e in Cheese)
'then don't encode
'because it will take 1 extra byte
If Mid$(InputString$, x + 1, 1) <> ThisChar And _
RepeatCount = 0 Then
RLEString = RLEString & ThisChar
LastChar = ThisChar
Else
RepeatCount = RepeatCount + 1
'We can only encode up to 254 repeats after that
'we have to start the new sequence again
If RepeatCount = 254 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
LastChar = ""
End If
End If
Else
If RepeatCount > 0 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
End If
RLEString = RLEString & ThisChar
LastChar = ThisChar
End If
Next x
'If the last chars in string are repeats
If RepeatCount > 0 Then
RLEString = RLEString & "~" & Chr$(RepeatCount)
RepeatCount = 0
End If
RLEEncode = RLEString
End Function
'调用举例：
Private MydsEncrypt As dsEncryp
dim Mtext as string
Mtext=MydsEncrypt.Encode(Mtext, 1)'加密后的内容写回原字符串中
全部回答
- 1楼网友：雪起风沙痕
- 2021-02-05 22:17
最简单的还是xor，屏幕保护密码就是采用xor加密的，ms设定了16个密钥，把屏保密码的每一位分别与对应的密钥做xor运算，把结果写入注册表，当用户输入密码时，从注册表读出之前写入的数据，再与密钥xor运算一次，得到真正的密码，与用户输入的密码相比较，相同则为合法用户
给你写一个简单的小例子，同样采用xor加密，不同的是以每字节的位置设为密钥，即第一位xor零，第二位xor一，第三位xor二，依次类推，当到256位，再xor零，257位xor一，如此循环反复，为文件的每一字节加密
此方法简便易行，且适用于任何文件类型
下面的代码以加密c:\boot.ini为例，执行完成后，c盘下多出boot_Encode.ini和boot_Uncode.ini两个文件
boot_Encode.ini是加密后的boot.ini，boot_Uncode.ini是重新解密的
你可以用16进制编辑器比较boot.ini和被加密后重新解密的boot_Uncode.ini是否完全一样
代码如下：
Private Sub Form_Load()
p$ = InputBox("输入欲加密文件的完整路径", "文件加密", "c:\boot.ini")
ReDim arr(FileLen(p)) As Byte
Open p For Binary As #1
arr = InputB(LOF(1), 1)
Close #1
For i& = 0 To UBound(arr)
arr(i) = arr(i) Xor (i Mod 256)
Next
p = StrReverse$(Replace$(StrReverse$(p), ".", ".edocnE_", , 1))
Open p For Binary As #1
Put #1, , arr
Close #1
MsgBox "加密完成"
ReDim arr(FileLen(p)) As Byte
Open p For Binary As #1
arr = InputB(LOF(1), 1)
Close #1
For i& = 0 To UBound(arr)
arr(i) = arr(i) Xor (i Mod 256)
Next
p = Replace(p, "_Encode", "_Uncode")
Open p For Binary As #1
Put #1, , arr
Close #1
MsgBox "解密完成"
End
End Sub
============
这基本上是一个完整的程序，可以直接使用，只是没写错误处理的部分，只要正常使用是可以的，别故意逗它玩就好了，呵呵
- 2楼网友：独行浪子会拥风
- 2021-02-05 21:53
private sub command1_click()
'在这里你可以自行加一个挑选文件夹的代码
call getfile(text1)
msgbox "共查找到: " & list1.listcount & " 个文件"
end sub
sub getfile(folderpath as string)
dim tmpstr as string
tmpstr = dir(folderpath & "*.*")
list1.clear
if tmpstr = "" then msgbox "本文件夹中没有任何文件": exit sub
me.cls: trec = 0
do while len(tmpstr) > 0
extnm = getextnm(tmpstr)
if extnm = "mp3" then
list1.additem tmpstr
trec = trec + 1
end if
tmpstr = dir
loop
end sub
我要举报
如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息，可以点下面链接进行举报！
点此我要举报以上问答信息
大家都在看
推荐资讯