エクセルのマクロで使用期限

エクセルのマクロでエクセルブック自体に使用期限を設けることは可能ですか？
例えば今使っている２０１７年という名前のブックを２０１８年１月１日にはパスワードがないと開けないようにしたいです。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2017/11/29 10:22

アイデアはいくつか持っています。

2018/1/1 ピッタリと行くかは別ですが、以下の場合は、2017年の12/29が最後の日とみなされて、開いて、閉めれば、パスワードを掛けられてしまう、という方法です。

正月すぎまでファイルを開かなければ、場合によっては、1月1日以降にパスワードが掛けられてしまうかもしれません。
1月1日に自動的に切り替えるには、外部プログラムとタイマーの登録が必要です。


'//ThisWorkbook モジュール
Option Explicit
Const mPSW As String ="abc" 'パスワード
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const XLMacro As Long = 52
Application.DisplayAlerts = False
''12月29日7時55分以降は、プロテクトを掛けて保存します。
If Now > DateSerial(2017, 12, 29) + TimeSerial(0, 7, 55) Then
　ThisWorkbook.SaveAs ThisWorkbook.Name, XLMacro, mPSW, mPSW
End If
Application.DisplayAlerts = True
End Sub

//

スタンドアロンで、もっと凝った作りをさせることも可能ですが、要求に応じたものを作って差し上げるというわけにはいかないことはご承知ください。あくまでも、ヒントを与えているだけだと思ってください。

なお、OneDrive for Business(Office 365 Premium) に、期限付きファイルというものがあります。
もうひとつは、Microsoft では、ARM(Azure Right Management)　
https://products.office.com/ja-jp/business/micro …
という方法もあります。

この回答へのお礼

お礼が遅くなり申し訳ございません、お早い回答ありがとうございます。参考にさせていただいてプログラムを作っていきます。ありがとうございました。

お礼日時：2017/12/03 08:25

No.3 回答者： WindFaller 回答日時： 2017/12/01 10:28

少し、本格的なものを作ってみました。

ご質問者さんがコメントを残していませんし、それを書いても、たぶん、評価は受けないとは思います。VBSですが、暗号化が可能です。Batchとは違うものです。Batchは、1回キリです。

もうこれは、マクロではなく、日時が来たら実行に移すマクロ・ウィルスと同等です。
MsgBox の所がコメントブロックになっているのは、実際は人知れず行うことになるからです。

この有効期限は、標準は3日ですから、仕事始めが、1月4日として6日までに実行されます。コントロールパネルの「タスクのスケジュール」に設定されていますから、用が済んだら、削除したほうがよいでしょう。拡張子は、xls, xlsx, xlsm の3つになっています。それ以外のものは、何もしないようになっています。(MsgBox でコメントを出しません)
必要なら、コードの中のシングルコーテーションを外してください。
'MsgBox "unknow Extention " & Ext

なるべくわかっている人にお使い願いたいです。
#1で書いたARMが標準的です。

'-----------------------
'//XlLock.Vbs
Dim objFS
Dim objFile
Const PSW ="xxx"
Const mPATH ="C:\Temp\"
Const oFNAME ="Test1m.xlsm"
Const fDFLT =51
Const fNML =-4143
Const fMCR= 52
Dim BaseName
Dim Ext, xt
Dim flg
'On Error Resume Next
Set objFS = CreateObject("Scripting.Filesystemobject")
If objFS.FileExists(mPATH &oFNAME)=False Then
' MsgBox "Not found " & oname & vbCrLf & "Please Check again!"
WScript.Quit
End If
BaseName= objFS.GetBaseName(mPATH & oFNAME)
Ext = objFS.GetExtensionName(mPATH & oFNAME)
If LCase(Ext) = "xls" Then
xt =fNML
ElseIf LCase(Ext) = "xlsx" Then
xt = fDFLT
ElseIf LCase(Ext) = "xlsm" Then
xt = fMCR
Else
'MsgBox "unknow Extention " & Ext
Wscript.Quit
End If
Dim xlApp
Dim wb
Set xlApp =CreateObject("Excel.Application")
''xlApp.visible =True
On Error Resume Next
Set wb=xlApp.Workbooks.Open(mPATH & oFNAME,0,0,,"","")
On Error Goto 0
If IsObject(wb) Then
wb.Protect PSW
WScript.Sleep 1000
xlApp.DisplayAlerts= False
wb.SaveAs mPATH & oFNAME,xt,PSW,PSW
xlApp.DisplayAlerts= True
wb.Close False
Call ErrEndProc(False)
Else
Call ErrEndProc(True)
End If
Set xlApp = Nothing
WScript.Quit
Function ErrEndProc(flg)
Set wb = Nothing
xlApp.Quit
Set xlApp = Nothing
If flg Then
'WScript.Echo "実行は失敗しました " & Err.Description
Else
'WScript.Echo "成功しました。"
End If
WScript.Quit
End Function
'--------------------------切り取り線-------

rem xlLock.vbs と一緒にしておいておくとよい。
rem 場所は適当に書き換えてください。
rem'----xlLock.bat---------------------
@echo off

schtasks /create /tn ChngeLock /sd 2018/01/04 /st 00:00:05 /tr "C:\Users\[YourID]\Documents\xlLock.vbs" /sc once

echo on

この回答へのお礼

本格的なプログラムを書いていただきありがとうございます。今後勉強してこのような高度なプログラムが使えるようになっていきたいと思います。ありがとうございました。

お礼日時：2017/12/03 08:28

No.2 回答者： ママチャリ 回答日時： 2017/11/29 11:07

Workbook_Openイベントプロシジャに仕込んでみました。

このマクロは、翌年以降かつPW未設定の場合にPWを設定して保存します。その後、再オープンすることにより、PWの入力が要求されるようになります。
Workbook_Openイベントプロシジャで自分自身を再オープンすることができるのか疑問だったのですが、とりあえず動作したので良しとしました。

Private Sub Workbook_Open()
Dim yyyy As Integer
With ThisWorkbook
yyyy = Split(.Name, "年", 2)(0)
If yyyy < Year(Now) And .HasPassword = False Then
.Password = "abc"
.Save
Workbooks.Open .FullName
End If
End With
End Sub

【注意点】とりあえず、ブック名から年を特定していますが、例えば「201ｘ年」みたいな想定外の名前だと異常終了します。この辺はご自分でご検討ください。

この回答へのお礼

お早い遅くなり申し訳ございません。お早いご回答ありがとうございます。シンプルで分かりやすいプログラムをご教示いただきましたので参考にさせていただきます。ありがとうございました。

お礼日時：2017/12/03 08:27