| |
初めまして、ＶＢＡ勉強中の者です。
【前提】
フォルダ内にある多数のファイルについてまとめて１つのパスワードを設定したいと考えています。
なお、フォルダ内にパスワードが設定されているファイルとされていないファイルが混在しているため、一旦全てパスワードを解除した後、まとめてパスワードを設定する必要があります。
各所を参考に、２つコードを入力したのですが、以下２点についてご教示いただければ幸いです。
（Excel2010を使用しています。）
【質問内容】
(1)下記コードのうち、Excel版は問題なく動作するのですが、Word版を実行したところ「実行時エラー'424":オブジェクトが必要です」と出てしまいます。修正方法をご教示いただけないでしょうか。（エラー箇所は★の部分）
(2)今回のマクロでは当該フォルダのみを動作の対象としていますが、下層フォルダもまとめて一括で動作するように設定はできないものでしょうか。
【入力コード（※設定したいパスワードが「aaa」の場合】
1.Excel版
Sub パスワードExcel()
Dim myfolder, myfn, myword, pwopen, pwclose
Dim pattern
'操作を選択
pattern = MsgBox("パスワード解除ならば「はい」、セットならば「いいえ」", vbYesNo)
If pattern = vbCancel Then
Exit Sub
End If
'パスワードをセット
myword = "aaa"
If pattern = vbYes Then
pwopen = myword
pwclose = ""
ElseIf pattern = vbNo Then
pwopen = ""
pwclose = myword
End If
'フォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "操作したいファイルのあるフォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
myfolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
'ファイルを操作
myfn = Dir(myfolder & "\*.xls*", vbNormal)
Do Until myfn = ""
Call ファイル開閉(myfolder & "\" & myfn, pwopen, pwclose)
myfn = Dir
Loop
End Sub
Function ファイル開閉(myfn, pwopen, pwclose)
Workbooks.Open Filename:=myfn, passWord:=pwopen
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=myfn, passWord:=pwclose, WriteResPassword:=""
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Function
2.Word版
Sub パスワードWord()
'フォルダ内の共通のパスワードがセットされた文書を連続して開き、解除して上書き保存。
'逆にフォルダ内の文書を連続して開き、共通のパスワードをセットして上書き保存。
Dim onoff As Long
Dim mypw, pwopen, pwclose, mypath, myfn As String
'操作を選択
onoff = MsgBox("パスワード解除ならば「はい」、セットならば「いいえ」", vbYesNo)
If onoff = vbCancel Then
Exit Sub
End If
'パスワードをセット
mypw = "aaa"
If onoff = vbYes Then
pwopen = mypw
pwclose = ""
ElseIf onoff = vbNo Then
pwopen = ""
pwclose = mypw
Else
Exit Sub
End If
'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
'ファイルの取得と実行
myfn = Dir(mypath & "*.doc*", vbNormal)
Do Until myfn = ""
'開
★Documents.Open FileName:=mypath & myfn, PasswordDocument:=pwopen★
'文末に改行を挿入し削除(何らかの変更がないと上書き保存できない)
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
'上書き保存
ActiveDocument.SaveAs Filename:=ActiveDocument.FullName, passWord:=pwclose, WritePassword:=""
ActiveWindow.Close
myfn = Dir
Loop
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
