エクセルVBAでBOOKに読み取りパスワード設定

質問

エクセル2013です。
以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。
しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか？教えてください。

Sub TEST01()
　　Dim myfdr As String, fname As String
　　Dim mb As Workbook, wb As Workbook
　　Dim n As Long
　　With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定
　　　　 If .Show = True Then
　　　　　　myfdr = .SelectedItems(1)
　　　　Else
　　　　　　MsgBox "キャンセルします。"
　　　　　　Exit Sub
　　　　End If
　　End With
　　Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
　　fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索
　　n = 2
　　Do Until fname = Empty '全て検索
　　　　Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
　　　　With mb.Sheets("Sheet1") '転記
　　　　　　.Cells(n, "B").Value = wb.FullName
　　　　　　.Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value
　　　　End With
　　　　n = n + 1 'カウント
　　　　Application.DisplayAlerts = False
　　　　wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"
　　　　wb.Close
　　　　Application.DisplayAlerts = True
　　　　fname = Dir 'フォルダ内の次のExcelブックを検索
　　Loop '繰り返す
　　MsgBox n - 2 & "件処理しましました。"
End Sub

回答No.1

real beatin（@realbeatin） · ベストアンサー

こんにちは。

"サブフォルダ"内のファイルに纏わる直接的な回答としては、
fsoを再帰処理と組み合わせる方法を紹介するのが
最もポピュラーな（一般認知度の高い）対応だと思います。
ただ、FolderPickerでフォルダを指定させるということだと、
例えば、ドライブまるごと"D:\"のような指定も可能になりますし、
指定されたフォルダによっては膨大な処理量にもなり兼ねません。
ですので、"サブフォルダも対象"ということだと、
（fsoであれDirであれ、再帰であれ非再帰であれ必ず）
何れかの段階で適当な制限を設けた上で実装することになります。
そういう意味では、実際の運用から離れた立場で、
安直にサンプルを提示することには非常に抵抗があります。
具体的な記述を掲げたとしても決してピンポイントな解答にはなり得ないこと、
そちらでの注意深い応用に委ねる部分が大きいことを理解しておいてください。

よくある設問としては、
　　サブフォルダの階層数を制限する
　　EscやBreakで処理を中断できるようにする
　　一定の件数毎に処理継続を問うようにする
等の対処を組み合わせて、
膨大な処理量による待ち時間やトラブルを回避できるようにするとか、、、ですね。
この点、★や■マークの行にて幾つか（あくまでも一例として）書いてみました。
過不足あれば、そちらで修正してみてください。

尚、以下の点については対策していません。
　　自ブックまたは既に開いているブックに対する.Open処理の排除
　　処理を途中で中止した場合のトランザクション
　　"リンクの更新"等、開くと問われるダイアログ
また、Application.DisplayAlertsについては、
各ブックを開いて保存する度に繰り返し設定変更の必要があるのか、
私には判断できませんので、ご提示の記述を踏襲します。

動作確認した環境は、win7 xl2010(x64)です。

' ＝＝＝
Option Explicit

' /// モジュール宣言部
Private oFSO As Object　'　▼ 参照設定しない場合
'Private oFSO As Scripting.FileSystemObject　'　▲ Scripting 参照設定 [Microsoft Scripting Runtime]
Private wkb0 As Workbook
Private n As Long
Private flgEsc As Boolean　'　★ 処理の中断を可能にする為の記述

' /// 実行マクロ
Sub ReW9054138()
Dim myfdr As String
　　With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定
　　　　If .Show = True Then
　　　　　　myfdr = .SelectedItems(1)
　　　　Else
　　　　　　MsgBox "キャンセルします。", vbInformation
　　　　　　Exit Sub
　　　　End If
　　End With
　　Set wkb0 = ThisWorkbook 'このコピー先ブックをwkb0とする。
　　Set oFSO = CreateObject("Scripting.FileSystemObject")　'　▼　FSO を設定
'　　Set oFSO = New Scripting.FileSystemObject　'　▲
　　n = 1　'　●カウンタのオリジンは　１
　　flgEsc = False　'　★
'　　Application.ScreenUpdating = False　'　？
'　　Application.EnableEvents = False　'　？
　　Call ブック検索(myfdr)
'　　Application.EnableEvents = True　'　？
'　　Application.ScreenUpdating = True　'　？
　　Set oFSO = Nothing
　　If flgEsc Then　'　★
　　　　MsgBox n - 1 & "件処理して、中断しました。", vbExclamation　'　★●カウンタのオリジンは　１
　　Else
　　　　MsgBox n - 1 & "件処理しましました。", vbInformation　'　●カウンタのオリジンは　１
　　End If
End Sub

' /// サブ
Private Sub ブック検索(ByVal sFolder As String, Optional ByVal nDim As Long)
Dim oFile As Object　'　▼
'Dim oFile As Scripting.File　'　▲
Dim oFolder As Object　'　▼
'Dim oFolder As Scripting.Folder　'　▲
Dim sFile As String
　　With oFSO.GetFolder(sFolder)
　　　　For Each oFile In .Files　'　フォルダ内の　ファイルを　全て検索
　　　　　　If flgEsc Then Exit For　'　★
　　　　　　DoEvents: DoEvents　'　★
　　　　　　sFile = oFile.Path
　　　　　　If LCase(oFSO.GetExtensionName(sFile)) Like "xls*" Then　'　拡張子判定
　　　　　　　　Call 個別処理(sFile)
　　　　　　End If
　　　　Next
'　　　　If nDim > 0 Then Exit Sub　'　例■サブフォルダの階層数をひとつ下までと制限する場合　イキ
　　　　For Each oFolder In .SubFolders　'　フォルダ内の　サブフォルダを　全て検索
　　　　　　If flgEsc Then Exit For　'　★
　　　　　　DoEvents: DoEvents　'　★
　　　　　　Call ブック検索(oFolder.Path, nDim + 1)　'　サブフォルダのパスを引数に　再帰処理
　　　　Next
　　End With
End Sub

' /// サブサブ
Private Sub 個別処理(ByVal sFile As String)
Dim wb As Workbook
　　If flgEsc Then Exit Sub　'　★
　　If n > 1 And n Mod 100 = 1 Then　'　100件毎に処理継続を問う例★●カウンタのオリジンは　１
　　　　If MsgBox(n - 1 & "件処理しましました。" & vbLf & "続行しますか？", vbInformation + vbYesNo) = vbNo Then　'　★●カウンタのオリジンは　１
　　　　　　flgEsc = True　'　★
　　　　　　Exit Sub
　　　　End If
　　End If
　　n = n + 1　'　●カウンタ
　　On Error GoTo ErrOpen_　'　◆ブックを開けない場合をトラップ
　　Set wb = Workbooks.Open(sFile)　'そのブックを開きwbとする。
　　On Error GoTo 0　'　◆
　　With wkb0.Sheets("Sheet1") '転記
　　　　.Cells(n, "B").Value = sFile
　　　　.Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value
　　End With
　　Application.DisplayAlerts = False
　　wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"
　　wb.Close SaveChanges:=False
　　Application.DisplayAlerts = True
Exit_:　'　◆
　　Exit Sub　'　◆
ErrOpen_:　'　◆
　　With wkb0.Sheets("Sheet1")　'　◆
　　　　.Cells(n, "B").Value = sFile　'　◆
　　　　.Cells(n, "C").Value = "Err:" & Err.Number　'　◆
　　End With　'　◆
End Sub

' ＝＝＝

もしも、fsoや再帰処理を用いない方法をお求めということでしたら、
　　半角チルダ＞『■Dir再帰|非再帰』
http://blog.goo.ne.jp/end-u/e/2a9f0ed1e468f4dfaa36c2af2c04e714
大いに参考になることと思います。

以上です。

お礼

realbeatin さん、今回もありがとうございます。
ご教示いただいた方法で目的を達することができました。
ご指摘いただいた注意点も、例えばリンクの更新は　UpdateLinks:=0　を入れ対応するなどいたしました。細かい点までご配慮いただき、深く感謝いたします。
これからもよろしくお願いいたします。
ありがとうございました。

補足

> そういう意味では、実際の運用から離れた立場で、
> 安直にサンプルを提示することには非常に抵抗があります。

すみません、使用する状況をちゃんと書くべきでしたね。
今回は個人情報管理の問題から、サーバー内の特定のフォルダ（下にサブフォルダが2階層まであります）内のエクセルデータにすべて読取りパスワードを設定する作業です。まだ実施しておりませんが、自分のPC内でのテストはうまくいきました。ありがとうございました。

回答No.4

NotFound404

追伸、
前言撤回
>ネットワークドライブでは /s 無効
Win7からNAS（Linuxサーバー）
　　　　WinXP・Win7の共有フォルダ
なら有効でした。検証が不十分でした、すみません。

Win10だとNAS（Linuxサーバー）はスムースに出来ましたが
Win10 ⇔ WinXP共有フォルダ・Win7共有フォルダだと
な～んか変です。
/s が効かない場合がある・反応が鈍い・パスワードを再度要求される場合。
Win10は仮想環境下でテスト中です。実際に使っているわけではありません。
私の環境設定がマズイのかも？

普段使いのサブフォルダも含めたファイル処理（検索など）は
私も同様にScripting.FilesystemObjectを利用している場合が多いです。
ただ、C:\直下からすべてのサブフォルダを検索する場合など
（通常やりませんが「遊び」でやる・・）
アクセス権やUAC関連起因のエラー処理を入れておかないと×です。

以上、既回答のも含めてご参考までに。

お礼

追加の質問にもお答えくださいましてありがとうございます。
いま、Windows7、Excel10で、共有サーバー内を検索してみました。
だいじょうぶでした。
ただ、残念ながらまだ自分で理解できないのでこれを実装できまねん。ごめんなさい。

回答No.3

NotFound404

追伸、
>リンク先に□□されて
□に『刺激』を入れてください。
リンク先の方と私は無縁です。
失礼しました。
追伸２、
コマンドプロンプトの、|clip はWindows7 Pro では使えますが、XPではClip.exeはないので不可。
Vistaは不明。
Windows10 Pro & Excel2016(32bit) でも動作確認できましたが
Home エディションで、|clip が使用できるかは不明です。

お礼

ありがとうございます。

回答No.2

NotFound404

realbeatinさんのリンク先にされて、あまのじゃっきー弐（へそまがりー）です。
何かの時に役に立つかも？

Sub test()
　　Const hideWindow As Integer = 0
　　Const bWaitOnReturn　As Boolean = True
　　Dim sCMD As String
　　Dim oWS As Object
　　Dim V As Variant, V1 As String, sT As String
　　Dim i As Long, j As Long

　　Set oWS = CreateObject("Wscript.Shell")

　　sCMD = "dir /s /b /a-d " '/a-d でフォルダ除外、ネットワークドライブでは /s 無効
　　sCMD = sCMD & "d:\" 'ここをFiledaialogから

　　oWS.Run "%ComSpec% /c " & sCMD & "|clip", hideWindow, bWaitOnReturn '|clipでクリップボードへ

　　V1 = GetObject("\", "htmlfile").ParentWindow.ClipboardData.GetData("text")
　　V = Split(V1, vbCrLf)
　　For i = 0 To UBound(V)
　　　　sT = Right(V(i), Len(V(i)) - InStrRev(V(i), ".")) '拡張子部分
　　　　If sT Like "xls*" Then 'sT = "xls" Or sT = "xlsx" Then
　　　　　　j = j + 1
　　　　　　Debug.Print j, i, V(i) 'イミディエイトウィンドウへ確認出力、Book処理をここへ
　　　　End If
　　Next
　　Set oWS = Nothing

End Sub

お礼

ありがとうございます。
再帰処理なしでも可能なんですね。この方法でもできました。
ただ、わたしには高度すぎてなぜできるのか理解できていません。
（コマンドプロンプトって使ったことがありませんので・・・）
でもこれがわかったらいろいろ使えそうですね。
ありがとうございました。

補足

> ネットワークドライブでは /s 無効

実際に使うのはネットワークドライブでつながっているサーバー内の特定のフォルダ（下に2階層あります）です。
その場合はどうなるのでしょうか？