エクセルVBAで読み取りパスワード回避

質問

エクセル2010です。
以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。
しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。
読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB"　などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。
そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。
（BOOK作成者にあとからパスワードを聞くため）
しかし、残念ながらどのように書けばいいのか思いつきません。
ご指導いただければ幸いです。

Sub TEST001()
　　Dim wb(1) As Workbook
　　Dim ws(1) As Worksheet
　　Dim myFdr As String, fn As String
　　Dim i As Long
　　With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定
　　　　If .Show = True Then
　　　　　　 myFdr = .SelectedItems(1)
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End With
　　Application.ScreenUpdating = False '画面更新を一時停止
　　Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。
　　Set ws(0) = wb(0).Sheets(1) 'wb(0)の１枚目のシートをws(0)とする。
　　fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索
　　Do Until fn = Empty '全て検索
　　　　Application.EnableEvents = False
　　　　Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。
　　　　Set ws(1) = wb(1).Worksheets(1)
　　　　i = i + 1
　　　　ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記
　　　　ws(0).Cells(i, "B").Value = wb(1).Name
　　　　ws(0).Cells(i, "C").Value = ws(1).Name
　　　　wb(1).Close (False) '保存せず閉じる
　　　　Application.EnableEvents = True
　　　　fn = Dir 'フォルダ内の次のExcelブックを検索
　　Loop '繰り返す
　　Application.ScreenUpdating = True '画面更新停止を解除
　　MsgBox i & "個取得"
End Sub

回答No.3

cj_mover · ベストアンサー

＃２、ｃｊです。＃２お礼欄へのレスです。

>> ThisWorkbook（の名前）を処理から除外しておいた方が安全ではあります。（コードは示しません）
>
>以下のようにしてみましたが、よろしいでしょうか？

はい。考え方として正しいですし、完全に解決出来ています。
拘るなら、ループの中で何度も取得し直す固定的なプロパティは、
事前に変数に纏めておいた方が何かと有利になりますね。

>> 同様にワークブックの二重起動についても考慮に入れた方がより無難になるかも、です。

>なるほど、すでに開いていることも考えられますね。
>残念ながら、この対応法がわかりません。

基本的なこととして、部分的に仕様を変える時には、視野を拡げて、
他の部分を含めて全体的な仕様への影響を考えに入れるよう習慣付けた方が好いです。
例えば、ThisWorkbook以外に、
転記元となるべきブックが実行前に既に開いていたとして、
そのブックに未保存データがある場合、どうしようか、とか。
仮に二重に開くことを回避できても、そのまま目を瞑って転記したとすると、
そのブックを上書き保存せずに閉じるようなことがあれば、
せっかく転記したリストに不整合が起きる可能性がある訳で、、、。
未保存の問題をクリア出来たとして、
その（開いていた）ブックを含めて、転記したブックを一様に閉じてしまったりしたら、
他の編集作業に支障があるのではないか、とか、、、。
まず大雑把な仕様の方向付けを仮に決めてみて、
その為に必要な技術で、足りないものがあれば、習得に努めて、
見通しが立ったら仮の仕様を再検証してみて、
大雑把に書いてみて、調整を加えて、ってな流れで考えてみたり、、、。
そんなこんなで、ユーザー目線を加味しながら妥協点を見つけてみて、仕上げていく、とか。
実務上の必要と十分に照らして仕様を整理することから始めないと、
"対応法が"わからないのは誰でも一緒です。

でも、なんか、今回の場合は、大変そうだから、
ThisWorkbookとPERSONAL.XLS以外のブックが開いていないことを確認
してから処理に進むようにしてみる、とか、
もう少し踏み込んで、、、
ThisWorkbookとPERSONAL.XLS以外に開いているブックが、
指定したフォルダにあるかどうかを先に確認して、
強制的に閉じちゃう、か、処理を中止して閉じてから実行して貰う、とか、
簡単に済ませちゃってもいいでしょうね。
近隣のＱＡを見ても、何も手当てしてない場合が多いようですし、、、。
ただ、今回はブックの開き方に特殊を認めている訳ですから、
二重に開くことを無視して実行するのだけは避けた方がいいでしょう。
最悪でも運用上の注意喚起（周知）は必要です。

参考に、前段に挙げた問題点に対して積極的に対策する方法を考えてみました。
次の投稿で書いたものを掲げてみます。
既出のコードでは、未保存の場合への対策が難しかったので、
手法的に大幅に変えたものになりました。
他にもケアしないといけないと気づいていることもあるのですが、
（大文字小文字を区別しないファイル名判定、とか、環境的な条件とか、色々）
今の処の（短時間で形にする為の）妥協点、ということです。
ただ、エラー処理の仕方は＃２よりだいぶマシになっています。
Shellを扱うかどうかは別にしても、
処理対象の一覧を先に取得しておくのは、
事後の処理に何かと融通性をもたらすかとは思います。
あくまで参考程度ですが、、、。

（次の投稿に続きます）

お礼

ありがとうございます。

回答No.4

cj_mover

（前の投稿の続きです）

Sub Re8470695j()

' '　ーーーーーーーーー
' ' フォルダ指定
Dim sDir As String　　'　　指定フォルダ名
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　' ' ▲例：自ブックのフォルダの一階層上を表示
　　　　.InitialFileName = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)　　' 　▲仮の例です。変更/省略可。
' ' ファイル名一覧取得
　　　　If .Show = True Then
　　　　　　sDir = .SelectedItems(1)
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End With

' '　ーーーーーーーーー
' ' ファイル名一覧取得
'Dim oWSH
Dim oWSH As Object　　'　　WScript.Shell　　As IWshRuntimeLibrary.WshShell　(Windows Scripting Host Object Model)
Dim sCmd As String　　'　　コマンドプロンプト
Dim sBuf As String　　'　　転記元ファイル名一覧（CrLf区切り）
　　Set oWSH = CreateObject("WScript.Shell")
　　' ' コマンドプロンプト：指定フォルダの"*xls*"ファイル名の一覧を取得
　　sCmd = "%ComSpec% /c dir " & sDir & "\*.xls/B"
　　With oWSH.Exec(sCmd)　　'　　コマンド実行
　　　　Do While .Status = 0
　　　　　　DoEvents　　'　　非同期実行を待機
　　　　Loop
　　　　' ' 転記元ファイル名一覧（CrLf区切り）を読み込み（前後にCrLf在り）
　　　　sBuf = vbCrLf & .StdOut.ReadAll
　　End With
　　Set oWSH = Nothing
　　If sBuf = vbCrLf Then MsgBox "空っぽ、中止": Exit Sub

' '　ーーーーーーーーー
' ' 転記元ファイル名一覧から自ブックを除外
　　If ThisWorkbook.Path = sDir Then
　　　　sBuf = Replace(sBuf, vbCrLf & ThisWorkbook.Name, "")
　　End If

' '　ーーーーーーーーー
' ' 転記元の各ブックが実行前から開いていた場合
' ' 未保存なら上書きを強制｜または処理中止
Dim oWbk As Workbook
　　For Each oWbk In Workbooks
　　' '　ーーーー実行前から開いていたブック名が転記元ファイル名一覧に含まれ、
　　' '　ーーーーそのブックが指定のフォルダに存在するならば
　　　　If InStr(sBuf, vbCrLf & oWbk.Name) Then
　　　　　　If oWbk.Path = sDir Then
　　　　　　　　If Not oWbk.Saved Then
　　　　　　　　　　If MsgBox("処理の続行には上書き保存する必要あり" & vbLf & vbTab & oWbk.Name & vbLf & "続行？", vbYesNo) = vbYes Then
　　　　　　　　　　　　oWbk.Save
　　　　　　　　　　Else
　　　　　　　　　　　　MsgBox "中止": Exit Sub
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Else
　　　　　　　　MsgBox "転記元に指定したブックと同名ブックが開いているので中止": Exit Sub
　　　　　　End If
　　　　End If
　　Next

' '　ーーーーーーーーー
' ' ファイル名一覧の、前後のCrLfトル
　　sBuf = Mid$(sBuf, 3, Len(sBuf) - 4)

' '　ーーーーーーーーー
' ' ファイル名一覧から、転記元ブック名の配列
Dim arrFn()　As String　　'　　転記元ブック名の配列
　　arrFn() = Split(sBuf, vbCrLf)

' '　ーーーーーーーーー
' ' 転記元ブック名の配列を総当りで、転記
Dim wsPrint As Worksheet　　'　　転記先シート
Dim wsLog As Worksheet　　'　　開けなかったブック名を出力するシート
Dim wsSrc As Worksheet　　'　　各転記元シート
Dim sFile As String　　'　　転記元の各ブック名
Dim i As Long　　'　　ループ用
Dim cnT As Long　　'　　正しく出力できた数
Dim cnF As Long　　'　　転記元ブックをOpen出来なかった数
Dim flgO As Boolean　　'　　各ブックが実行前から開いていたかどうか
　　Set wsPrint = ThisWorkbook.Sheets(1)　　'　　転記先シート
　　Set wsLog = ThisWorkbook.Sheets(3)　　'　 開けなかったブック名を出力するシート
　　Application.ScreenUpdating = False　　'　　画面更新を一時停止
　　Application.EnableEvents = False　　'　　イベントを一時抑止
　　cnT = 0:　　cnF = 0

　　For i = 0 To UBound(arrFn())
　　　　flgO = False
　　　　Set wsSrc = Nothing
　　　　sFile = arrFn(i)

　　' '　ーーーー転記元ブック開いている、と仮定して
　　' '　ーーーー転記元シートにアクセスしてみる
　　　　On Error Resume Next
　　　　Set wsSrc = Workbooks(sFile).Worksheets(1)
　　　　On Error GoTo 0

　　' '　ーーーー転記元シートへのアクセスに失敗していたならば
　　　　If wsSrc Is Nothing Then
　　' '　ーーーー転記元ブックはパスワード指定なしで開ける、と仮定して
　　' '　ーーーー転記元シートにアクセスしてみる
　　　　　　On Error Resume Next
　　　　　　Set wsSrc = Workbooks.Open(sDir & "\" & sFile, Password:="", UpdateLinks:=False, ReadOnly:=True).Worksheets(1)
　　　　　　On Error GoTo 0
　　　　Else
　　' '　ーーーー転記元シートへのアクセスに成功していたならば
　　' '　ーーーー転記元ブックは実行前から開いている
　　　　　　flgO = True
　　　　End If

　　' '　ーーーー転記元シートへのアクセスに失敗していたならば
　　　　If wsSrc Is Nothing Then
　　　　　　cnF = cnF + 1
　　' '　ーーーー開けなかったブック名を出力
　　　　　　wsLog.Cells(cnF, 1).Value = sFile
　　　　Else
　　' '　ーーーー転記元シートへのアクセスに成功していたならば
　　　　　　With wsSrc　　'　　転記元シート
　　　　　　　　cnT = cnT + 1
　　　　　　　　' ' B2の値、転記元の各ブック名、転記元の各シート名、を纏めて出力
　　　　　　　　wsPrint.Cells(cnT, "A").Resize(, 3).Value = Array(.Range("B2"), .Parent.Name, .Name)
　　　　　　　　' ' 元々開いていなかったブックならば保存せず閉じる
　　　　　　　　If Not flgO Then .Parent.Close False
　　　　　　End With
　　　　End If
　　Next i
　　Set wsPrint = Nothing:　　Set wsLog = Nothing:　　Set wsSrc = Nothing

　　Application.EnableEvents = True　　'　　イベント抑止を解除
　　Application.ScreenUpdating = True　　'　　画面更新停止を解除
　　MsgBox UBound(arrFn()) + 1 & "個中　" & cnT & "個取得　" & cnF & "個失敗"
　　Erase arrFn()
End Sub

お礼

cj_moverさん、何度もありがとうございます。

> 転記元となるべきブックが実行前に既に開いていたとして、そのブックに未保存データがある場合、どうしようか、とか。

未保存データのようなことはまったく想定していませんでした。
危うくとんでもないものを作ってしまうところでした。
そのような場合の対応を私が決めるわけにもいかないので、とりあえずは

For Each wb(1) In Workbooks
If wb(1).Name <> ThisWorkbook.Name And Not StrConv(wb(1).Name, vbUpperCase) Like "PERSONAL.XLS*" Then
MsgBox "他のBookが開いているようです。" _
& vbCrLf & "お手数ですが、一旦他のBOOKを閉じてから開始してください。", vbCritical
Exit Sub
End If
Next wb(1)

で、逃げることにします。(個人用マクロBOOKの存在を考慮したつもりです)
ご指導有難うございました。

回答No.2

cj_mover

こんにちは。お邪魔します。

対策としては、
　　Openｎ メソッドの引数として、Password:="" を指定すること
　　On Error ステートメントから、Err オブジェクトを問い合わせて分岐
という２点です。

下に示した例では、
・変更点を◆マークで、こちらで一例として示している点を▲マークでそれぞれ示しています。
・「Openメソッドが失敗した場合」の処理がシンプルですので、On Error Resume Nextを使います。
・例として「Openメソッドが失敗した場合は」という意味で
　　　　If Err.Number <> 0 Then '▲例えばエラーならすべて
のように書いています。
　　　　If Err.Number <> 1004 Then
と書くと、「Excelワークブックの属性が原因でOpenメソッドが失敗した場合は」という意味になります。
Err.Number = 1004 に加えて、Err.Descriptionを判別に加えれば、
「パスワード指定漏れに因ってOpenメソッドが失敗した場合は」という意味に多少近付けるようですが、
ぴったりとしたものはすぐには思い付かず、あまり考えてもいません。。
「Openメソッドが失敗した場合は」という判別の方が実践的であろうと思っています。
・例としてThisWorkbook.Sheets(3)のＡ列に、開けなかったブック名を出力します。
書き振りに一貫性を持たせるなら、
ThisWorkbook.Sheets(3)を変数に格納したり、「開けなかったブック」をカウントすることになるのでしょうけれど、
特に手を加えてません。
自分なら、オブジェクトの扱いとして変数を用いるのは
　　Dim wsPrint As Worksheet　　'　　転記先シート　Set wsPrint = ThisWorkbook.Sheets(1)
　　Dim wsLog As Worksheet　　'　　開けなかったブック名を出力するシート　Set wsLog = ThisWorkbook.Sheets(3)
ぐらいで、後はすべてWithフレーズで済ませるように書くことが多いです。
・Application.EnableEvents がループの内にあることの意図が判らなかったのですが、一応、外に出しました。
・この手の処理でFolderPickerを使ってブックを開く場合は、
ThisWorkbook（の名前）を処理から除外しておいた方が安全ではあります。（コードは示しません）
同様にワークブックの二重起動についても考慮に入れた方がより無難になるかも、です。

Sub Re8470695()
　　Dim wb(1) As Workbook
　　Dim ws(1) As Worksheet
　　Dim myFdr As String, fn As String
　　Dim i As Long
　　With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定
　　　　 If .Show = True Then
　　　　　　 myFdr = .SelectedItems(1)
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End With
　　Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。
　　Set ws(0) = wb(0).Sheets(1) 'wb(0)の１枚目のシートをws(0)とする。
　　fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索
　　Application.ScreenUpdating = False '画面更新を一時停止
　　Application.EnableEvents = False '◆
　　Do Until fn = Empty '全て検索
　　　　On Error Resume Next '◆
　　　　Set wb(1) = Workbooks.Open(myFdr & "\" & fn, Password:="", UpdateLinks:=False, ReadOnly:=True) '◆そのブックを開きwb(1)とする。
　　　　If Err.Number <> 0 Then '▲例えばエラーならすべて
　　　　　　wb(0).Sheets(3).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = fn '▲例えばwb(0).Sheets(3)のＡ列に出力
　　　　Else '◆
　　　　　　Set ws(1) = wb(1).Worksheets(1)
　　　　　　i = i + 1
　　　　　　ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記
　　　　　　ws(0).Cells(i, "B").Value = wb(1).Name
　　　　　　ws(0).Cells(i, "C").Value = ws(1).Name
　　　　　　wb(1).Close (False) '保存せず閉じる
　　　　End If '◆
　　　　On Error GoTo 0 '◆
　　　　fn = Dir 'フォルダ内の次のExcelブックを検索
　　Loop '繰り返す
　　Application.EnableEvents = True '◆
　　Application.ScreenUpdating = True '画面更新停止を解除
　　MsgBox i & "個取得"
End Sub

お礼

cj_moverさん、いつもありがとうございます。
なるほど、このようなやり方なんですね、初めて知りました！

> ThisWorkbook（の名前）を処理から除外しておいた方が安全ではあります。（コードは示しません）

以下のようにしてみましたが、よろしいでしょうか？

> 同様にワークブックの二重起動についても考慮に入れた方がより無難になるかも、です。

なるほど、すでに開いていることも考えられますね。
残念ながら、この対応法がわかりません。

Sub Re8470695()
Dim wb(1) As Workbook
Dim ws(2) As Worksheet
Dim myFdr As String, fn As String
Dim i As Long
With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定
If .Show = True Then
myFdr = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。
Set ws(0) = wb(0).Sheets(1) 'wb(0)の1枚目のシートをws(0)とする。
Set ws(2) = wb(0).Sheets(3) 'wb(0)の3枚目のシートをws(2)とする。
fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索
Application.ScreenUpdating = False '画面更新を一時停止
Application.EnableEvents = False '◆
Do Until fn = Empty '全て検索
If fn <> wb(0).Name Then
On Error Resume Next '◆
Set wb(1) = Workbooks.Open(myFdr & "\" & fn, Password:="", UpdateLinks:=False, ReadOnly:=True) '◆そのブックを開きwb(1)とする。
If Err.Number <> 0 Then '▲例えばエラーならすべて
ws(2).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = fn '▲wb(0).Sheets(3)のＡ列に出力
Else '◆
Set ws(1) = wb(1).Worksheets(1)
i = i + 1
ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記
ws(0).Cells(i, "B").Value = fn
ws(0).Cells(i, "C").Value = ws(1).Name
wb(1).Close (False) '保存せず閉じる
End If '◆
On Error GoTo 0 '◆
End If
fn = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.EnableEvents = True '◆
Application.ScreenUpdating = True '画面更新停止を解除
MsgBox i & "個取得"
End Sub

回答No.1

NotFound404

ちょっと試した限りでは・・・、
パスワードの設定を一切行っていないファイルを
set bk=workbooks.open("e:\boo.xlsx",password="yomi",writerespassword:="kaki")
パスワードの部分は無視されて開くようです。
一方どちらかにパスワードの設定がある場合
set bk=workbooks.open("e:\boo.xlsx",password="",writerespassword:="")
では、実行時エラー 1004 になりましたので
エラー処理で行うとかでは？

お礼

ありがとうございます。
やはりエラー処理ですね、勉強になります。