人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

ExcelやPowerPointなどのOffice関連のファイルに、読取の際にパスワードを求められる場合があります。
パスワードはもちろんわかっているので、投入後ファイルを開き、パスワードが聞かれない別ファイルとして保存し直すことがよくあります。

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

●質問者: yoshifuku
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● cx20
●100ポイント

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

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

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
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
◎質問者からの返答

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

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

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

関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ