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

パスワードはもちろんわかっているので、投入後ファイルを開き、パスワードが聞かれない別ファイルとして保存し直すことがよくあります。

ファイル数が多いと、この一連の作業がかなり大変なため、なんとか簡単にやり遂げられないかと思っています。
いい方法がありましたらお願いします。(パスワードは全ファイル同じです)

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/09/23 14:25:35
  • 終了:2011/09/30 14:30:07

回答(1件)

id:cx20 No.1

cx20回答回数603ベストアンサー獲得回数1072011/09/23 17:35:29

ポイント100pt

複数ファイル対応したパスワード一括解除ツールを探してみましたが、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

' カラム名の一覧(1行分)を取得
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

' カラムデータの一覧(1行分)を取得
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)
NoFilePathOldNameNewNameFileExtUsePasswordUnlcokResult
1C:\home\edu\VBScript\UnlockPassword\ExcelHello.xls xlsFalse 
2C:\home\edu\VBScript\UnlockPassword\ExcelHello_password.xlsHello_password_NonPassword.xlsxlsTrueTrue
3C:\home\edu\VBScript\UnlockPassword\PowerPointhello.ppt pptFalse 
4C:\home\edu\VBScript\UnlockPassword\PowerPointhello_password.ppthello_password_NonPassword.pptpptTrueTrue
5C:\home\edu\VBScript\UnlockPassword\WordHello.doc docFalse 
6C:\home\edu\VBScript\UnlockPassword\WordHello_password.docHello_password_NonPassword.docdocTrueTrue
id:miku1973

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

  

もし作成いただければ本当に嬉しいです。

どうぞよろしくお願い致します。

2011/09/24 07:41:19

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません