Sub sample()
'このコードを使用する場合はMicrosoft Scripting Runtimeを参照設定してください。
Dim objFS As New FileSystemObject
Dim ofdFD As Office.FileDialog
Dim strPath, Pass As String
Dim res As Integer
'passwordを設定
Pass = InputBox("Backupファイルにかけるパスワードを入力してください。", "パスワード設定")
If Pass = "" Then Exit Sub
On Error GoTo Error1
strPath = ThisWorkbook.Path 'このVBAコードのあるファイルのパスを指定
'選択する方法の設定今回の【msoFileDialogFilePicker】はファイルを選択する設定
Set ofdFD = Application.FileDialog(msoFileDialogFolderPicker)
With ofdFD 'ダイヤログボックスの設定
'ダイヤログボックスのファイル表示の設定
.InitialView = msoFileDialogViewDetails
'初期表示フォルダの設定【 & "\"】がないとファイル名がフォルダ名になってしまうので注意
.InitialFileName = strPath & "\"
'複数選択をしないよう設定
.AllowMultiSelect = False
End With
If ofdFD.Show() = -1 Then 'OKや参照・開くなどを押すと返り値【-1】が返ってくる
Application.DisplayAlerts = False
'Backup後の保存先&ブック名
ActiveWorkbook.SaveAs ofdFD.SelectedItems(1) & "\" & "psBackupFile.xlsm", Password:=Pass 'Backup保存するコード
ThisWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
Exit Sub
Else
MsgBox "キャンセルが押されました"
End If
Set ofdFD = Nothing
Error1: 'エラーが発生した場合はここへ飛ぶ
MsgBox "エラー番号:" & Err.Number & vbLf & _
"エラー内容:" & Err.Description & vbLf
End Sub
コメントを残す