フォルダ内のファイル(エクセル・ワード)を全て書き込みパスワード設定にして 保存したいのですが、数が多く、全てのファイルを開いて パスワード設定に保存するマクロをどなたか教えて下さい。

フォルダ内のファイル(エクセル・ワード)を全て書き込みパスワード設定にして 保存したいのですが、数が多く、全てのファイルを開いて パスワード設定に保存するマクロをどなたか教えて下さい。

Visual Basic277閲覧xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

「VBScript」による回答ですので、「Windows限定」です。 このプログラムは、これから処理したいフォルダにプログラムファイルを放り込んで、ダブルクリック(「シングルクリック」→「Enter」の方が確実)するだけです。 フォルダ内に存在する拡張子が「doc」、「docx」、「docm」、「xls」、「xlsx」、「xlsm」のファイルに「書き込みパスワード」を設定します。 最後に「Finished!」と表示しますので、「OK」を押して、終了してください。 以下のプログラムを、メモ帳かテキストエディタに貼り付け、「~.vbs」という名前で保存します。 「~」の部分は、何でもかまいませんが、「.vbs」の部分は、必ず、半角です。 できたプログラムファイル(「~.vbs」ファイル)を、これからパスワードをかけたいファイル群が存在するフォルダに放り込んで、ダブルクリックするだけです。 Option Explicit Dim bk, e, ex, dc, f, gf, p, so, wd p = "xyz" Set so = CreateObject("Scripting.FileSystemObject") Set gf = so.GetFolder(so.GetParentFolderName(WScript.ScriptFullName)) Set wd = CreateObject("Word.Application") wd.Application.DisplayAlerts = False wd.Visible = False Set ex = CreateObject("Excel.Application") ex.Application.DisplayAlerts = False ex.Visible = False For Each f In gf.Files e = LCase(so.GetExtensionName(f.Name)) If e = "doc" or e = "docx" or e = "docm" Then Set dc = wd.Documents.Open(gf & "\" & f.Name) wd.Selection.TypeText " " dc.Range(0, 0).Delete dc.SaveAs gf & "\" & f.Name,,,,, p dc.Close Set dc = Nothing ElseIf e = "xls" or e = "xlsx" or e = "xlsm" Then Set bk = ex.Workbooks.Open(gf & "\" & f.Name) bk.SaveAs gf & "\" & f.Name,,, p bk.Close Set bk = Nothing End If Next wd.Quit ex.Quit Set wd = Nothing Set ex = Nothing Set gf = Nothing Set so = Nothing MsgBox("Finished!") 簡単な説明です。 Option Explicit 「厳密に」というような意味ですが、気にしないでください。 p = "xyz" パスワードです。 Set so = CreateObject("Scripting.FileSystemObject") ファイルやフォルダを扱えるようにしています。 Set gf = so.GetFolder(so.GetParentFolderName(WScript.ScriptFullName)) プログラムファイルが存在するフォルダを取得しています。 Set wd = CreateObject("Word.Application") ワードを扱えるようにしています。 wd.Application.DisplayAlerts = False wd.Visible = False 「上書きしますか?」などと聞いてこないように、また、ワードを表示しません。 Set ex = CreateObject("Excel.Application") エクセルを扱えるようにしています。 ex.Application.DisplayAlerts = False ex.Visible = False 「上書きしますか?」などと聞いてこないように、また、エクセルを表示しません。 For Each f In gf.Files プログラムファイルが存在するフォルダ内のすべてのファイルを1つずつ処理。 e = LCase(so.GetExtensionName(f.Name)) 拡張子を「e」に代入しています。 If e = "doc" or e = "docx" or e = "docm" Then 拡張子が「doc」または「docx」または「docm」の場合、 Set dc = wd.Documents.Open(gf & "\" & f.Name) そのドキュメントを開いています。 wd.Selection.TypeText " " dc.Range(0, 0).Delete ワードは、編集作業を行わないと保存されないため、開いたとたん、意味もなく全角スペースを1文字入力し、すぐにその文字を削除しています。 dc.SaveAs gf & "\" & f.Name,,,,, p 「書き込みパスワード」を設定して保存しています。 dc.Close Set dc = Nothing 閉じています。 ElseIf e = "xls" or e = "xlsx" or e = "xlsm" Then 拡張子が「xls」または「xlsx」または「xlsm」の場合、 Set bk = ex.Workbooks.Open(gf & "\" & f.Name) そのブックを開いています。 bk.SaveAs gf & "\" & f.Name,,, p 「書き込みパスワード」を設定して保存しています。 bk.Close Set bk = Nothing 閉じています。 End If Next を、すべてのファイルで繰り返しています。 wd.Quit ワードそのものを終了しています。 ex.Quit エクセルそのものを終了しています。 Set wd = Nothing Set ex = Nothing Set gf = Nothing Set so = Nothing MsgBox("Finished!") あとは、終了処理で、最後に「Finished!」と表示しています。

ThanksImg質問者からのお礼コメント

ありがとう御座いました。 使わせていただきます。 これで時間を多く使わずにすみます。

お礼日時:2018/4/16 16:59