VBA實現 加解密文件
 

以下程式碼只需存檔成 .vbs 或 .wsf 就可 滑鼠雙擊
利用 windows 內建的 Microsoft Windows Script 來執行

※原則上建議用在不要太大的純文字檔上(.txt)，畢竟 .vbs是直譯器的應用很費資源的
※個人保證上述腳本在未經變動下是不會造成任何破壞的(病毒)
※vbs如無法執行請安裝 Microsoft Windows Script 請至
http://www.microsoft.com/downloads/d...C-0EA28C9A5D9D
http://www.microsoft.com/downloads/d...playLang=zh-cn
P.S. 簡體版請自行更換下方語系

缺點:
因為是用純數字字元記載加密文件，所以容易看出規則破解，及會有容量倍數成長的問題 (VBS沒有VB這麼多涵式好用，這點請有興趣的網友自己試著改進 ^^||)

腳本可改良的地方很多
比如密碼可改成文字(不過加密後的文件size會變大，當然可以用壓縮算式，不過寫起來太累人了...^^||)
或加入解密密碼混和讀寫
或文字改成 byte進制檔來存取
還有執行方式有是...(要寫絕對路徑的判讀)

列表: List.bat (為列出此地路徑下的所有.txt檔，當然也可以自己更改搜尋條件 ※生成的列表檔為Crypt.List請勿更名)

===加密: Crypt.vbs===

Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fsot, ft
Dim ValCrypt
Dim BoolMsg
On Error Resume Next

ValCrypt = Cint(InputBox("請輸入加密密碼 ※需為大於等於100之正整數"))
BoolMsg = MsgBox("是否指定單一文件加密(答""否""的話就是使用 Crypt.List批次處理)",vbYesNoCancel,"指定加密文件")
If BoolMsg = vbNo Then
Set fsot = CreateObject("Scripting.FileSystemObject")
Set ft = fsot.OpenTextFile("Crypt.List", ForReading)
While Not ft.AtEndOfStream
ReadWriteFile ft.ReadLine
Wend
ElseIF BoolMsg = vbYes Then
ReadWriteFile InputBox("請輸入File完整名稱")
End IF

On Error GoTo 0

Sub ReadWriteFile(FileNameStr)
Dim fso, f1, f2, i
Dim NewText, ReadAllTextFile
Dim ValTristate

Set fso = CreateObject("Scripting.FileSystemObject")
Set f1 = fso.OpenTextFile(FileNameStr, ForReading, False, TristateUseDefault)
Set f2 = fso.OpenTextFile(FileNameStr, ForReading, False, TristateTrue)

ReadAllTextFile = f1.ReadAll
NewText = f2.ReadAll
If StrComp(ReadAllTextFile, NewText) Then
ValTristate = TristateUseDefault '開啟檔案為系統預設狀態
Else
ValTristate = TristateTrue 'Unicode
End If
f2.Close
NewText = Empty

ReadAllTextFile = StrReverse(ReadAllTextFile)
For i = 1 to LenB(ReadAllTextFile)
NewText = NewText + CStr(AscB(MidB(ReadAllTextFile, i, 1)) + ValCrypt)
Next

Set f1 = fso.OpenTextFile(FileNameStr + ".Crypt", ForWriting, True, ValTristate)
f1.Write NewText
End Sub

===List.bat ===
dir /b .\*.txt > Crypt.List

===解密: Decode.vbs===

Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fsot, ft
Dim ValCrypt
Dim BoolMsg
On Error Resume Next

ValCrypt = Cint(InputBox("請輸入當初設定之文件解密密碼(正整數)"))
BoolMsg = MsgBox("是否解密所有.Crypt文件(答""是""的話會根據Crypt.List文件列表;答""否""的話請輸入單一文件)",vbYesNoCancel,"指定解密文件")
If BoolMsg = vbYes Then
Set fsot = CreateObject("Scripting.FileSystemObject")
Set ft = fsot.OpenTextFile("Crypt.List", ForReading, False, TristateUseDefault)
While Not ft.AtEndOfStream
ReadWriteFile ft.ReadLine, ValCrypt
Wend
ElseIF BoolMsg = vbNo Then
ReadWriteFile InputBox("請輸入文件完整名稱"), ValCrypt
End IF
On Error GoTo 0

Sub ReadWriteFile(FileNameStr, ByValCrypt)
Dim fso, f1, f2, i
Dim NewText, ReadAllTextFile
Dim ValTristate, ValLen

Set fso = CreateObject("Scripting.FileSystemObject")
Set f1 = fso.OpenTextFile(FileNameStr + ".Crypt", ForReading, False, TristateUseDefault)
Set f2 = fso.OpenTextFile(FileNameStr + ".Crypt", ForReading, False, TristateTrue)

ReadAllTextFile = f1.ReadAll
NewText = f2.ReadAll
If StrComp(ReadAllTextFile, NewText) Then
ValTristate = TristateUseDefault '開啟檔案為系統預設狀態
Else
ValTristate = TristateTrue 'Unicode
End If
f2.Close
NewText = Empty

ValLen = Len(CStr(ByValCrypt))
For i = 1 to Len(ReadAllTextFile) Step ValLen
NewText = NewText + ChrB(CInt(Mid(ReadAllTextFile, i, ValLen))- ByValCrypt)
Next
NewText = StrReverse(NewText)

Set f1 = fso.OpenTextFile("Decode_" + FileNameStr, ForWriting, True, ValTristate)
f1.Write NewText
End Sub

原理還是簡單解說一下

一開始會要求輸入 密碼

再來
不論加密還是解密，都有兩個模式
一為 單一檔案
一為 處理 Crypt.List

選好後
就進入 加/解密 副程式處理

副程式內一開始做了 UTF-8、UniCode、ANSI 之文檔字碼判斷
知道是哪種文檔字碼後再以相對應的開檔模式
開啟->處理->存檔