vbscript エクセルパスワード解除动スクリプト

Posted 2021-05-22

Option Explicit
Dim max
Dim min
'===============================================================================
':: 最大(max)・最小(min)のパスワード長を設定してください
max = 10
min = 3

'===============================================================================
':: ここから下はいぢらないでください
Dim i
Dim filename
Dim objFile
Dim objExcel

'エクセルオブジェクト生成
Set objExcel = CreateObject("Excel.Application")

'解除ファイル選択処理 = 選択するまでループ
With objExcel.FileDialog(1)
	.Title = "パスワードを解除するファイルを選択してください。"
	.Filters.Add "Excel (*.xls,*.xlsx)", "*.xls;*.xlsx", 1
	.AllowMultiSelect = False
End With
objExcel.DisplayAlerts = False

Do While True
	objExcel.Visible = False
	If objExcel.FileDialog(1).Show = -1 Then
		'objExcel.WindowState = 2
		For Each objFile In objExcel.FileDialog(1).SelectedItems
			filename = objFile
		Next
	End If
	
	objExcel.Visible = False
	If filename = False Then
		filename = MsgBox("ファイルを選択してください。", vbCritical + vbOKCancel)
		If filename = 2 Then
			Wscript.Quit
		End If
	ElseIf InStr(LCase(filename), ".xls") > 0 Then
		Exit Do
	Else
		filename = MsgBox("エクセルファイルを選択してください。", vbCritical + vbOKCancel)
		If filename = 2 Then
			Wscript.Quit
		End If
	End If
Loop

'後始末
Set objFile = Nothing
Wscript.Echo "解除ファイル : " & filename

'解除処理開始
For i = min To max
	Call passUnlock("", i)
Next

'後始末
Wscript.Echo "パスワードが見つかりませんでした..."
objExcel.Quit
Set objExcel = Nothing
Wscript.Quit

Sub passUnlock(pass, paslen)
	Dim i
	Dim p
	On Error Resume Next
	If Len(pass) >= paslen Then Exit Sub
	For i = &H20 To &H7F
		If Len(pass & Chr(i)) <> paslen Then
			Call passUnlock(pass & Chr(i), paslen)
		Else
			p = Chr(i)
			Wscript.Echo pass & p
			Err.Clear
			objExcel.Workbooks.Open filename, 0, False, 5, pass & p
			If Err.Number = 0 Then
				Wscript.Echo "パスワードを解除しました。［ " & pass & p & " ］" & vbCrLf & "必ず何かに書き写してください"
				filename = MsgBox("パスワードを解除しました。［ " & pass & p & " ］", vbInformation)
				objExcel.Visible = True
				Wscript.Quit
			ElseIf Err.Number <> 1004 Then
				Wscript.Echo "予期しないエラーが発生しました。[ " & Err.Description & " ]"
				filename = MsgBox("予期しないエラーが発生しました。[ " & Err.Number & " ] " & Err.Description, vbCritical)
				objExcel.Quit
				Set objExcel = Nothing
				Wscript.Quit
			End If
		End If
	Next
End Sub