ExcelやPowerPointなどのOffice関連のファイルに、読取の際にパスワードを求められる場合があります。

複数ファイル対応したパスワード一括解除ツールを探してみましたが、Excel の事例がほとんどで、Word や PowerPoint に対応した例が見つかりませんでした。

基本的には、Word や PowerPoint も Excel 同様、プログラムで自動化させることができるハズなので、ツール化はできそうです。

（お急ぎでなければ、連休中の空いた時間にでも作ってみようかと思います。）

以下は、Excel での一括解除のツール（コードサンプル）です。

■ エクセル(excel)のパスワード解除について | OKWave

http://okwave.jp/qa/q6796439.html

■ TTak's Office Excel フォルダ内のすべてのファイルを一気にパスワード保護(2010)

http://www.geocities.jp/ttak_ask/office_docu/ef13_21.html

以下は、Word ファイルのパスワードを解除するサンプルコードです。

■ パスワードを使用して Word および Excel のドキュメントに対するアクセスを保護する

http://msdn.microsoft.com/ja-jp/library/cc376910.aspx

• 追記（2011.09.25）

取り合えず版を作成してみました。

• 注意事項
  • 動作は無保証とさせて下さい。
  • 必ずバックアップを取ってから実行お願いします。
  • Office 2003 環境にのみ対応しています（他の環境ではテストしていません）
  • ネットワーク越しのファイル（UNCパス）については未テストです。
  • フォルダ階層が深い場合、うまくいかない可能性があります。
  • ファイル数が多い場合、相当時間がかかる可能性があります。

• 使い方
  1. 以下のスクリプトを「UnlockPassword.vbs」として任意の場所に保存します。
  2. g_strPassword（読み取りパスワード）を設定します。
  3. g_strFilePath（Office文書があるフォルダ）を設定します。
  4. コマンドラインにて以下のコマンドを実行します。

CScript UnlockPassword.vbs //Nologo > result.txt

' File Name : UnlockPassword.vbs
' Usage : CScript UnlockPassword.vbs //Nologo > result.txt

Option Explicit

Const g_strFileExtList = "xls,doc,ppt"   ' 対象拡張子
Const g_strPassword    = "password"      ' 変更前のパスワード
Const g_strNewPassword = ""              ' 変更後のパスワード（ブランクの場合、パスワードはクリアされます。）
Const g_strFilePath    = "C:\home\edu\VBScript\UnlockPassword" ' Office文書があるフォルダ（サブディレクトリも対象）
Const g_strPrefix      = ""              ' 変更後ファイル名プレフィックス
Const g_strSuffix      = "_NonPassword"  ' 変更後ファイル名サフィックス

' ADO
Const adInteger = 3
Const adBoolean = 11
Const adVarChar = 200
Const adFldIsNullable = 32
Const adPersistXML = 1

Dim g_fso

' 検索ファイル数
Dim g_nFileCount
g_nFileCount = 0

Call Main()

Sub Main()
    ' ファイル操作用オブジェクト準備
    Set g_fso = CreateObject("Scripting.FileSystemObject")

    ' 対象ファイル名格納用レコードセットの用意
    Dim rs
    Set rs = MakeRecordset()
    
    ' 対象ファイル検索
    Dim folder
    Set folder = g_fso.GetFolder( g_strFilePath )
    SearchFileNameToRecordset rs, folder, g_strFileExtList
    
    ' パスワード使用チェック
    CheckUsePassword rs
    
    ' パスワード一括変更
    ChangePassword rs, g_strPrefix, g_strSuffix, g_strPassword, g_strNewPassword

    ' 実行結果表示
    Dim strDelimiter
    strDelimiter = vbTab ' 区切り文字を指定（vbTab : タブ文字）
    ShowRecordset rs, strDelimiter

End Sub

' 対象ファイル検索
Sub SearchFileNameToRecordset( rs, folder, strFileExtList )
    Dim file
    For Each file In folder.Files
        Dim strFileExt
        strFileExt = g_fso.GetExtensionName( file.Name )
        ' 対象ファイル拡張子チェック
        If IsExistItemList( strFileExt, strFileExtList ) Then
            g_nFileCount = g_nFileCount + 1
            rs.AddNew()
            rs.Fields( "No" )        = g_nFileCount
            rs.Fields( "FilePath" )  = folder.Path
            rs.Fields( "OldName" )   = file.Name
            rs.Fields( "FileExt" )   = strFileExt
            rs.Update()
        End If
    Next
    Dim subFolder
    For Each subFolder In folder.SubFolders
        SearchFileNameToRecordset rs, subFolder, strFileExtList
    Next
End Sub

' 対象ファイル拡張子チェック
Function IsExistItemList( strFileExt, strFileExtList )
    Dim strItems
    strItems = Split( strFileExtList, ",")
    Dim strItem
    For Each strItem In strItems
        If strItem = strFileExt Then
            IsExistItemList = True
            Exit Function
        End If
    Next
    IsExistItemList = False
End Function

' データ格納用レコードセットの準備
Function MakeRecordset()
    Dim rs
    Set rs = CreateObject("ADODB.Recordset")
    rs.Fields.Append "No",             adInteger
    rs.Fields.Append "FilePath",       adVarChar, 511
    rs.Fields.Append "OldName",        adVarChar, 255
    rs.Fields.Append "NewName",        adVarChar, 255
    rs.Fields.Append "FileExt",        adVarChar, 255
    rs.Fields.Append "UsePassword",    adBoolean
    rs.Fields.Append "UnlcokResult",   adBoolean
    rs.Open
    Set MakeRecordset = rs
End Function

' データ表示
Sub ShowRecordset( rs, strDelimiter )
    On Error Resume Next

    rs.MoveFirst
    
    ' タイトル行
    Dim strLine
    strLine = GetFieldNameList( rs, strDelimiter )
    WScript.Echo strLine ' タイトル行を出力
    
    ' データ行
    While Not rs.BOF And Not rs.EOF
        strLine = GetFieldValueList( rs, strDelimiter )
        WScript.Echo strLine ' データ行を出力
        rs.MoveNext
    Wend
    
End Sub

' カラム名の一覧（１行分）を取得
Function GetFieldNameList( rs, strDelimiter )
    Dim strResult
    
    Dim bFirst
    bFirst = True
    Dim fld
    For Each fld In rs.Fields
        If bFirst Then
            strResult = Chr(34) & fld.Name & Chr(34)
            bFirst = False
        Else
            strResult = strResult & strDelimiter & Chr(34) & fld.Name & Chr(34)
        End If
    Next
    
    GetFieldNameList = strResult
End Function

' カラムデータの一覧（１行分）を取得
Function GetFieldValueList( rs, strDelimiter )
    Dim strResult
    
    Dim bFirst
    bFirst = True
    Dim fld
    For Each fld In rs.Fields
        If bFirst Then
            strResult = Chr(34) & fld.Value & Chr(34)
            bFirst = False
        Else
            strResult = strResult & strDelimiter & Chr(34) & fld.Value & Chr(34)
        End If
    Next
    
    GetFieldValueList = strResult
End Function

' 新しいファイル名を作成（ファイル名：<prefix>+ベース名+<suffix>.<拡張子>）
Function MakeNewFileName( strFileName, strPrefix, strSuffix )
    Dim strResult
    Dim strBaseName
    Dim strFileExt
    strBaseName = g_fso.GetBaseName( strFileName )
    strFileExt = g_fso.GetExtensionName( strFileName )
    strResult = strPrefix & strBaseName & strSuffix & "." & strFileExt
    MakeNewFileName = strResult
End Function

' パスワード存在チェック
Function CheckUsePassword( rs )
    Dim bResult
    Dim strFilePath
    Dim strPathName
    Dim strFileName
    Dim strFileExt
    
    rs.MoveFirst
    While Not rs.BOF And Not rs.EOF
        strPathName = rs( "FilePath" )
        strFileName = rs( "OldName" )
        strFileExt  = rs( "FileExt" )
        strFilePath = strPathName & "\" & strFileName
        Select Case strFileExt
        Case "xls"
            bResult = IsUsePassword_xls( strFilePath )
        Case "doc"
            bResult = IsUsePassword_doc( strFilePath )
        case "ppt"
            bResult = IsUsePassword_ppt( strFilePath )
        End Select
        rs("UsePassword") = bResult ' 実行結果をセット
        rs.Update
        rs.MoveNext
    Wend
    CheckUsePassword = True
End Function

' パスワード一括変更
Function ChangePassword( rs, strPrefix, strSuffix, strPassword, strNewPassword )
    Dim bResult
    Dim strFilePath
    Dim strPathName
    Dim strFileName
    Dim strFileExt
    Dim strNewFilePath
    Dim strNewFileName
    
    rs.Filter = "UsePassword = True" ' パスワード付きファイルのみ処理対象とする
    rs.MoveFirst
    While Not rs.BOF And Not rs.EOF
        strPathName = rs( "FilePath" )
        strFileName = rs( "OldName" )
        strFileExt  = rs( "FileExt" )
        strFilePath = strPathName & "\" & strFileName
        ' 新しいファイル名を取得（ファイル名：<prefix>+ベース名+<suffix>.<拡張子>）
        strNewFileName = MakeNewFileName( strFilePath, strPrefix, strSuffix )
        strNewFilePath = strPathName & "\" & strNewFileName
        ' ファイル形式毎にパスワード変更処理を実行
        Select Case strFileExt
        Case "xls"
            bResult = ChangePassword_xls( strFilePath, strNewFilePath, strPassword, strNewPassword )
        Case "doc"
            bResult = ChangePassword_doc( strFilePath, strNewFilePath, strPassword, strNewPassword )
        case "ppt"
            bResult = ChangePassword_ppt( strFilePath, strNewFilePath, strPassword, strNewPassword )
        End Select
        rs("NewName") = strNewFileName
        rs("UnlcokResult") = bResult ' 実行結果をセット
        rs.Update
        If Not bResult Then
            rs.Filter = "" ' フィルター解除
            ChangePassword = bResult
            Exit Function
        End If
        rs.MoveNext
    Wend
    rs.Filter = "" ' フィルター解除
    ChangePassword = bResult
End Function

' パスワード存在チェック（Excelファイル）
Function IsUsePassword_xls( strFileName )
    Dim bResult
    bResult = False
    On Error Resume Next
    Dim excel
    Set excel = CreateObject("Excel.Application")
    Dim book
    Set book = excel.Workbooks.Open( strFileName, , , , "" )
    If Err.Number <> 0 Then
'         WScript.Echo Err.Description
         bResult = True ' ファイルが開けない場合、パスワード有りと判定する
    End If
    book.Close
    excel.Quit
    IsUsePassword_xls = bResult
End Function

' パスワード存在チェック（Wordファイル）
Function IsUsePassword_doc( strFileName )
    Dim bResult
    bResult = False
    On Error Resume Next
    Dim word
    Set word = CreateObject("Word.Application")
    Dim doc
    ' パスワード引数無しで、Open メソッドを呼び出すと、
    ' パスワード入力ダイアログが表示され、処理が中断してしまう為、
    ' ダミーのパスワードを引数に設定し、ダイアログ表示を抑制する。
    Set doc = word.Documents.Open( strFileName, , , ,"unknown" )
    If Err.Number <> 0 Then
'         WScript.Echo Err.Description
         bResult = True ' ファイルが開けない場合、パスワード有りと判定する
    End If
    doc.Close
    word.Quit
    IsUsePassword_doc = bResult
End Function

' パスワード存在チェック（PowerPointファイル）
Function IsUsePassword_ppt( strFileName )
    Dim bResult
    bResult = False
    On Error Resume Next
    Dim ppt
    Set ppt = CreateObject("PowerPoint.Application")
    Dim pre
    ' パスワード引数無しで、Open メソッドを呼び出すと、
    ' パスワード入力ダイアログが表示され、処理が中断してしまう為、
    ' ダミーのパスワードを引数に設定し、ダイアログ表示を抑制する。
    Set pre = ppt.Presentations.Open( strFileName & "::unknown", , , False )
    If Err.Number <> 0 Then
 '        WScript.Echo Err.Description
         bResult = True ' ファイルが開けない場合、パスワード有りと判定する
    End If
    pre.Close
    ppt.Quit
    IsUsePassword_ppt = bResult
End Function

' パスワード変更（Excelファイル）
Function ChangePassword_xls( strFileName, strNewFileName, strPassword, strNewPassword )
    Dim excel
    Set excel = CreateObject("Excel.Application")
    Dim book
    Set book = excel.Workbooks.Open( strFileName, , , ,strPassword )
    book.Password = strNewPassword
    book.SaveAs strNewFileName
    book.Close
    excel.Quit
    ChangePassword_xls = True
End Function

' パスワード変更（Wordファイル）
Function ChangePassword_doc( strFileName, strNewFileName, strPassword, strNewPassword )
    Dim word
    Set word = CreateObject("Word.Application")
    Dim doc
    Set doc = word.Documents.Open( strFileName, , , ,strPassword )
    doc.Password = strNewPassword
    doc.SaveAs strNewFileName
    doc.Close
    word.Quit
    ChangePassword_doc = True
End Function

' パスワード変更（PowerPointファイル）
Function ChangePassword_ppt( strFileName, strNewFileName, strPassword, strNewPassword )
    Dim ppt
    Set ppt = CreateObject("PowerPoint.Application")
    Dim pre
    Set pre = ppt.Presentations.Open( strFileName & "::" & strPassword, , , False )
    pre.Password = strNewPassword
    pre.SaveAs strNewFileName
    pre.Close
    ppt.Quit
    ChangePassword_ppt = True
End Function

• 実行結果（result.txt）