如何用vba代码批量根据已有密码表尝试打开并删除选定目录下excel文件密码?

楼主
kevinchengcw

Q: 如何用vba代码批量根据已有密码表尝试打开并删除选定目录下excel文件密码?
A: 代码如下:

Sub test()
Dim mPath, ExApp As Object, WB As Workbook, PSW, FN$, N%, Str$, OK As Boolean
PSW = Array("", "258", "369") '建立密码数组(包含无密码的情况,由程序依次测试)
Set mPath = Application.FileDialog(msoFileDialogFolderPicker) '设置文件夹选择框
If mPath.Show = -1 Then '如果显示了选择框并选择了文件夹,则
CreateObject("wscript.shell").Run Environ("comspec") & " /c dir /s/b """ & mPath.SelectedItems(1) & "\*.xls?"">""" & ThisWorkbook.Path & "\list.txt""", 0, 1 '利用命令行得到该文件夹下含子文件夹的全部excel文件列表并等待列表生成完毕
Set ExApp = CreateObject("excel.application") '创建一个excel进程用于尝试打开文件
With ExApp
.Visible = False '进程为不可见且不显示警告信息
.DisplayAlerts = False
End With
On Error Resume Next '出错时继续执行
Str = "" '初始化记录未能修改密码的文件的变量为空值
With CreateObject("scripting.filesystemobject") '创建FSO项目用于操作列表文件
With .opentextfile(ThisWorkbook.Path & "\list.txt") '利用FSO项目打开列表文件
Do While Not .atendofstream '当未达到列表文件末端时继续循环
FN = .readline '读取一行内容
If Trim(FN) <> "" And FN <> ThisWorkbook.FullName Then '如果内容有效,且不是当前工作簿的全路径(防止选择当前文件所在目录或上层目录后导致重复打开的问题)
OK = False '初始化完成变量为假
For N = LBound(PSW) To UBound(PSW) '循环各个密码(从空密码开始,尝试利用各个密码打开文件)
Set WB = ExApp.Workbooks.Open(FN, Password:=PSW(N)) '利用当前循环到的密码尝试打开文件
If Not WB Is Nothing Then '未能打开文件,则文件变量是nothing,如果不是nothing及说明打开了,则
If PSW(N) = "" Then '如果是用空密码打开的,则直接关闭不保存
WB.Close False
Else '否则将密码设置成无,然后保存并关闭
WB.Password = ""
WB.Close True
End If
OK = True '完成变量设置为真
Set WB = Nothing '将工作簿变量置为nothing,防止将当前内容带入下一循环
Exit For '退出当前循环
End If
Next N '循环到下一密码
End If
If OK = False Then Str = Str & vbNewLine & FN '如果循环结束完成变量仍为假,则将当前工作簿名以换行符串接到变量中
Loop '循环到列表下一行
End With
End With
ExApp.Quit '全部执行完毕后退出创建的excel进程
Set WB = Nothing '清空创建的项目
Set ExApp = Nothing
Kill ThisWorkbook.Path & "\list.txt" '删除列表文件
End If
If Str <> "" Then '如果记录未完成密码修改的变量内容不为空,则显示记录的未修改的文件清单
MsgBox "如下文件密码未清除" & Str
Else '否则显示提示信息
MsgBox "全部完成"
End If
End Sub

详见素材源帖.

2楼
い卋玑┾宝珼

向K版学习VBA代码