如何利用vba代码根据已知密码集批量将所选文件夹中全部excel文档去除密码？

楼主 kevinchengcw	Q: 如何利用vba代码根据已知密码集批量将所选文件夹中全部excel文档去除密码？ A: 代码如下： Sub test() Dim WB As Workbook, FN$, Log$, Str$, Arr, Rules, N&, I&, T&, OK As Boolean, mTime Arr = Split(",111,123,222,333,321", ",") '设置密码集,含空密码,并拆分放入数组 T = UBound(Arr) - LBound(Arr) + 1 '提取出密码集数量(此种写法不用考虑option base的设置) ReDim Rules(1 To T * T, 1 To 2) '设定密码集组合数组(考虑打开和写入密码两种) For N = LBound(Rules) To UBound(Rules) '循环将密码集中密码进行组合,放入组合数组中 Rules(N, 1) = Arr(Int((N - 1) / T)) Rules(N, 2) = Arr((N - 1) Mod T) Next N FN = ThisWorkbook.Path & "\list.txt" '设置文件列表文件全路径 Log = ThisWorkbook.Path & "\log.txt" '设置日志文件全路径 On Error Resume Next '设置容错 mTime = Timer '记录处理程序开始时间(未记录密码集生成的时间) If Dir(FN) <> "" Then Kill FN '清除可能存在的列表文件或同名文件 If Dir(Log) <> "" Then Kill Log '清除可能存在的日志文件或同名文件 Open Log For Append As #1 '以附加的方式创建新的日志文件 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "程序开始" '输出开始时间记录到日志文件 With Application.FileDialog(msoFileDialogFolderPicker) '调用文件夹选择对话框 .Title = "请选择要处理的文件夹：" '设置显示的标题 If .Show = -1 Then '如果有选择文件夹,则 CreateObject("wscript.shell").Run Environ("comspec") & " /c dir /s/b """ & .SelectedItems(1) & "\.xls?"">""" & FN & """", 0, 1 '利用wsh对象运行命令行dir命令获取选定文件夹下的全部excel工作簿清单利用输出重定向输出到列表文件中并等待命令执行完成后返回程序继续执行 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "取得文件列表完成" '向日志文件输出列表获取结束的时间 Else '如果未选择文件(点"取消"或直接关闭了文件夹选择框),则 Close #1 '关闭日志文件 Kill Log '因未有有价值数据存在,故删除日志文件 Exit Sub '退出程序 End If End With If Dir(FN) <> "" Then '如果列表文件已生成,则 Application.DisplayAlerts = False '关闭警告信息(防止打开,另存等操作中弹出信息提示) Application.ScreenUpdating = False '关闭屏幕刷新以提高运行速度 With CreateObject("scripting.filesystemobject") '创建FSO对象用于操作列表文件 With .opentextfile(FN) '打开列表文件 T = 0 '处理文件总数值初始化为0 I = 0 '成功处理文件总数值初始化为0 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "开始处理文件列表中文件" & vbCrLf _ & "***********************************************************************" '输出开始处理列表中文件的时间到日志文件 Do While Not .atendofstream '循环操作直到到达列表文件末尾 Str = Trim(.readline) '读取一行数据,赋值给变量 If Str <> "" And Str <> ThisWorkbook.FullName And Dir(Str) <> "" Then '如果变量内容不为空,且不是本工作簿全路径名,目标文件确实存在,则 T = T + 1 '处理文件总数加1 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "处理文件：" & Str '输出处理开始的时间和文件名到日志文件 OK = False '初始化处理成功与否的逻辑变量值为假 For N = LBound(Rules) To UBound(Rules) '循环利用密码组合数组中的各组数据打开文件,直到成功打开或组合用完 Set WB = Workbooks.Open(Str, Password:=Rules(N, 1), writerespassword:=Rules(N, 2)) '尝试以当前组合打开当前循环到的工作簿 If Not WB Is Nothing Then '如果成功打开,则 With WB .Password = "" '清空打开文件密码 .WritePassword = "" '清空写入权限密码 .SaveAs Str '文件另存为覆盖另存一次(可以避免因写入权限有用户限定造成的写入权限密码去除失败) .Close False '关闭文件 End With Set WB = Nothing '清空对象,以防止影响下一次判断 OK = True '成功标题设置为真 Exit For '退出循环 End If Set WB = Nothing '清空对象,以防止影响下一次判断 Next N If OK Then '如果处理成功,则 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "处理成功" & vbTab _ & "原打开密码：" & IIf(Rules(N, 1) = "", "无", """" & Rules(N, 1) & """") & vbTab _ & "原写权限密码：" & IIf(Rules(N, 2) = "", "无", """" & Rules(N, 2) & """") '输出处理完成的时间及原来的密码设定到日志文件 I = I + 1 '成功处理文件数加1 Else '否则 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "处理失败，未能找到正确密码组合！" '输出处理完成时间及提示处理失败的日志文本到日志文件 End If End If Loop '循环到下一行数据 .Close '全部数据行处理完成后关闭列表文件 End With End With Application.DisplayAlerts = True '打开警告提示 Application.ScreenUpdating = True '打开屏幕刷新 Print #1, "************************************************************************" & vbCrLf _ & Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "文件全部处理完成" & vbCrLf _ & "共处理文件 " & T & " 个，处理成功 " & I & " 个,失败 " & T - I & " 个，共耗时 " & Format(Timer - mTime, "0秒") '输出完成时间及处理数据的总结到日志文件 Else '如果未生成列表文件,则 Print #1, Format(Now, "yyyy-m-d hh:mm:ss") & vbTab & "文件列表生成出错，程序退出！" '输出时间及出错文件到日志文件 End If Close #1 '关闭日志文件 Kill FN '删除列表文件 Shell Environ("comspec") & " /c notepad """ & Log & """", vbHide '通过shell命令调用命令行利用词事本打开日志文件显示结果 End Sub 注: 之所以对每个处理数据的结果即时写入日志文件,而不采用写入变量后最后写入日志文件,是为了防止程序中途意外退出后无法知道处理进度.
2楼 546	学习了
3楼 wise	K哥真厉害。
4楼 chenlifeng	太神奇了!