マクロについて質問です！ 使用OS Windows7 MicroSoft Office 2013 の

マクロについて質問です！
使用OS Windows7
MicroSoft Office 2013
のPCにて、同じフォルダ内のファイルにパスワードを設定する方法が分かる方がいらっしゃいましたら教えて頂けないでしょうか？
エクセルとワードに設定できたら有り難いです！
1000個近いファイルに一つずつ設定していくのはなかなか苦行なので、助けて頂けたら幸いですm(_ _)m

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2017/07/27 20:57

#1の回答者です。

ある程度は想定したことですが、まさか、両方のマクロを同じモジュールに貼り付けるようなことはしないと思いますが。Excel用マクロは、Excel で、Word用はWordになるということです。

私のマクロのポイントは、単にパスワードを入れるだけではなく、すでにパスワードをつけたものは、パスし、またパスワードなしに元に戻せることとを考えたものであることです。

''Excel用　標準モジュール（先頭から）
>'(Option Explicit)
>Const PSW As String = "00"　'パスワード
>Const myPATH As String = "C:\Users\ExcelFolder\" '末尾は￥のこと　登録フォルダー
>Dim errCnt As Long
>Sub MainProgram()

この最初の部分が、どこに置くか、初歩の初歩なのですが、それにつまづく人が大勢います。Excel は、その点でややこしいのです。

「標準モジュール」はどこにあるか？

ということからでしょうか？

ほんの1～2日もあれば、VBAの使い方の要領は分かるはずです。
http://excelvba.pc-users.net/fol1/1_1.html

なお、最近のMicrosoft Office のプロテクト・セキュリティは、ARM（旧IRM)を使うようになっています。

https://products.office.com/ja-jp/business/micro …
一度、ご検証されても良いかと思います。

この回答へのお礼

デスクトップで起動したら一応出来ました！
ただ、読み取り専用で開けてしまうのですが、それを開けなくすることは可能ですか？

お礼日時：2017/08/01 10:05

No.2 回答者： LHS07 回答日時： 2017/07/27 16:53

フォルダーにパスワードを設定するソフトがありますが

ただ、解除できなくなると悲惨です。

1人で3日あれば設定できるじゃないですか？

この回答へのお礼

回答頂きありがとうございます！
フリーソフト等は残念ながら使えないです！

お礼日時：2017/07/27 17:58

No.1 回答者： WindFaller 回答日時： 2017/07/27 00:22

最初、トライアルでやって大丈夫と分かってから、全部を実行してください。

Excel側はほぼ固まっているのですが、Word は、試行錯誤で、エラーの検出が思ったようにいっていません。パスワードつきは、自動でパスするように作られています。


''Excel用　標準モジュール（先頭から）
'(Option Explicit)
Const PSW As String = "00"　'パスワード
Const myPATH As String = "C:\Users\ExcelFolder\" '末尾は￥のこと　登録フォルダー
Dim errCnt As Long
Sub MainProgram()
Dim fname As String
　errCnt = 0
　If Dir(myPATH, vbDirectory) = "" Then MsgBox "フォルダーがありません。", vbExclamation: Exit Sub
　fname = Dir(myPATH & "*.xls?", vbNormal)
　Do While fname <> ""
　　If (GetAttr(myPATH & fname) And vbNormal) = vbNormal Then
　　　If ThisWorkbook.Name <> fname Then '同名ファイル名不可
　　　　Call addPassWord(fname)
　　　End If
　　End If
　　fname = Dir
　Loop
　Application.ScreenUpdating = False
　If errCnt > 0 Then
　　MsgBox errCnt & "件のエラーがあります。イミディエイト・ウィンドウを見てください。", vbExclamation
　Else
　　MsgBox "終了", vbInformation
　End If
End Sub
Sub addPassWord(fname As String)
　 On Error Resume Next
　　With Workbooks.Open(myPATH & fname, , , , "", "")
　　　If Err.Number = 0 Then
　　　　Application.DisplayAlerts = False
　　　　.SaveAs myPATH & fname, , PSW, PSW
　　　　Application.DisplayAlerts = True
　　　　.Close False
　　　ElseIf Err.Number <> 1004 Then
　　　　Debug.Print fname　'エラーを起こしたファイル名を記録
　　　　errCnt = errCnt + 1
　　　End If
　　End With
　　Err.Clear
　　On Error GoTo 0
End Sub

''---------------------------
''Word用　ThisDocument(先頭から)

Const PSW As String = "00"　'パスワード
Const myPATH As String = " "C:\Users\ExcelFolder\"　 '末尾は￥のこと　登録フォルダー
Dim errCnt As Long
Sub MainProgramWord()
Dim fname As String
　errCnt = 0
　If Dir(myPATH, vbDirectory) = "" Then MsgBox "フォルダーがありません。", vbExclamation: Exit Sub
　fname = Dir(myPATH & "*.doc?", vbNormal)
　Do While fname <> ""
　　If (GetAttr(myPATH & fname) And vbNormal) = vbNormal Then
　　　If ThisDocument.Name <> fname Then '同名ファイル名不可
　　　　Call addPassWord(fname)
　　　End If
　　End If
　　fname = Dir
　Loop
　Application.ScreenUpdating = False
　If errCnt > 0 Then
　　MsgBox errCnt & "件のエラーがあります。イミディエイト・ウィンドウを見てください。", vbExclamation
　Else
　　MsgBox "終了", vbInformation
　End If
End Sub
Sub addPassWord(fname As String)
Dim myDoc As Document
　　On Error Resume Next
　　Application.DisplayAlerts = False
　　Set myDoc = Documents.Open(myPATH & fname, , , , "")
　　Application.DisplayAlerts = True
　　On Error GoTo 0
　　If Not myDoc Is Nothing Then
　　With myDoc
　　　　.Password = PSW
　　　　Application.DisplayAlerts = False
　　　　.SaveAs myPATH & fname
　　　　Application.DisplayAlerts = True
　　　　.Close False
　　End With
　　End If
　
End Sub

この回答へのお礼

お答え頂きありがとうございます！
ただ、マクロ初心者のため、イマイチ上手く動作しません！Σ(×_×;)!
折角組んでいただいたのに活かせないのは悔しいですm(_ _)m

お礼日時：2017/07/27 14:12