Excel·VBA破解密码

上一篇文章《Excel·VBA数组排列函数》，实现了VBA排列功能，而排列重要应用就是破解密码

Excel密码破解

支持破解纯数字、数字字母混合、纯字母等形式的密码
因破解速度不快，支持排列分段破解

Sub excel破解密码()'利用排列函数破解密码，如果密码正确则打开文件，支持排列断点、正向、反向查找Dim arr, brr, file_name$, pw$, wb, start_t&, end_t&, step_t&, i&, j&tm = Timer: On Error Resume Next  '密码错误时，不加本句会弹窗报错file_name = "E:\测试\密码文件.xlsx"  '文件arr = Array(1, 2, 3, 4, 5, 6)  '可能的密码元素'arr = Array(0, 1, 2, 3, "a", "b", "c")  '混合密码brr = permut_arr(arr, 6)       '密码位数，排列start_t = 0: end_t = 0         '遍历排列的起止位置，1为第1个，-1为最后一个If start_t > 0 And end_t > 0 And start_t <= end_t Then  '起止位置>0，正向查找step_t = 1ElseIf start_t < 0 And end_t < 0 And start_t >= end_t Then  '起止位置<0，反向查找start_t = UBound(brr) + start_t + 1: end_t = UBound(brr) + end_t + 1: step_t = -1ElseIf start_t = 0 And end_t = 0 Then  '起止位=0，全部查找start_t = LBound(brr): end_t = UBound(brr): step_t = 1ElseDebug.Print "参数错误": Exit SubEnd Ifopened = FalseFor i = start_t To end_t Step step_tpw = Join(brr(i), ""): j = j + 1Set wb = Workbooks.Open(filename:=file_name, Password:=pw)If TypeName(wb) = "Workbook" ThenDebug.Print "破解完成，密码为：" & pw,Debug.Print "遍历" & j & "种密码，用时：" & Format(Timer - tm, "0.00")opened = True: Exit For  '跳过剩余密码排列End IfNextIf opened = False Then Debug.Print start_t & "-" & end_t & "序号密码排列都不对，用时：" & Format(Timer - tm, "0.00")
End Sub

破解密码测试

密码排列	6选6共720种排列	7选6共5040种排列
耗时（秒）	74.64	542.53

破解速度不到10个/秒，属实不快，如果是银行卡此类10选6的密码估计需要4.5小时，如果是数字字母混合36选8可能需要4200年，这还是没有考虑字母大小写、元素重复的情况

zip、rar密码破解

支持破解纯数字、数字字母混合、纯字母等形式的密码
因破解速度不快，支持排列分段破解
使用 Shell 函数运行 winrar.exe 程序破解密码《Office VBA 参考·Shell 函数》
《WinRAR中文版》

Sub zip破解密码()'利用排列函数破解密码，如果密码正确则解压文件，支持排列断点、正向、反向查找Dim fso, arr, file_name$, save_path$, pw$, rarexe$, rarstr$, result&tm = Timer: Set fso = CreateObject("Scripting.FileSystemObject")file_name = "E:\测试\密码987654.zip"  '压缩文件save_path = "E:\测试\解压成功\"  '保存路径，建议为新文件夹rarexe = "E:\software\winrar\winrar.exe"  'winrar程序路径arr = Array(4, 5, 6, 7, 8, 9)  '可能的密码元素brr = permut_arr(arr, 6)       '密码位数，排列start_t = 0: end_t = 0         '遍历排列的起止位置，1为第1个，-1为最后一个If start_t > 0 And end_t > 0 And start_t <= end_t Then  '起止位置>0，正向查找step_t = 1ElseIf start_t < 0 And end_t < 0 And start_t >= end_t Then  '起止位置<0，反向查找start_t = UBound(brr) + start_t + 1: end_t = UBound(brr) + end_t + 1: step_t = -1ElseIf start_t = 0 And end_t = 0 Then  '起止位=0，全部查找start_t = LBound(brr): end_t = UBound(brr): step_t = 1ElseDebug.Print "参数错误": Exit SubEnd IfIf fso.FolderExists(save_path) = False Thenfso.CreateFolder (save_path)ElseIf Dir(save_path) <> Empty Then Debug.Print "建议保存文件夹为空，便于后续判断是否解压成功，程序终止": Exit SubEnd IfFor i = start_t To end_t Step step_tpw = Join(brr(i), ""): j = j + 1rarstr = rarexe & " e -y -p" & pw & " " & file_name & " " & save_path  '解压命令result = shell(rarstr, vbHide)   'Shell函数运行命令，隐藏窗口If Dir(save_path) <> Empty Then  '由于解压耗时，就算解压成功也判断为空，故建议分段破解Debug.Print "解压成功，密码为：" & pw & "，由于解压耗时，密码也可能是本密码的前几个之一"Debug.Print "遍历" & j & "种密码，用时：" & Format(Timer - tm, "0.00")Exit For  '跳过剩余密码排列End IfNextSet fso = Nothing  '释放内存If Dir(save_path) = Empty ThenDebug.Print start_t & "-" & end_t & "序号密码排列都不对，用时：" & Format(Timer - tm, "0.00")Debug.Print "查看是否解压成功，由于解压耗时，密码也可能是最后几个之一"ElseDebug.Print start_t & "-" & end_t & "序号中存在正确的密码，建议采用二分法查找"End If
End Sub