読み取り専用で開かせてマクロの保存だけを許可するブック
2024年05月15日
会社でNAS上のファイルをみんなで編集することって結構ある。
誰かが開いていると編集権が手に入らず待ちぼうけなんてことも。
ファイル共有機能で対策はできるものの、どっちも好きじゃない。
①エクセルのブック共有機能を使う
→編集箇所が競合したときに困る
②OneDriveでファイル共有機能を使う
→保存場所がNASじゃなくなるので、使いづらい
今回は、NAS上のファイルに書き込みパスワードを設定することで、
読み取り専用で開くことを強要して、ブックに埋め込んだマクロを使って保存する方法を考えた。
誰かが開いていると編集権が手に入らず待ちぼうけなんてことも。
ファイル共有機能で対策はできるものの、どっちも好きじゃない。
①エクセルのブック共有機能を使う
→編集箇所が競合したときに困る
②OneDriveでファイル共有機能を使う
→保存場所がNASじゃなくなるので、使いづらい
今回は、NAS上のファイルに書き込みパスワードを設定することで、
読み取り専用で開くことを強要して、ブックに埋め込んだマクロを使って保存する方法を考えた。
ベースとしたのは以下の記事のソース。
「上書き保存してバックアップ」
アクティブブックの内容をバックアップ（コピー）して、上書き保存するというもの。
バックアップ処理は共通でOKだけど、読み取り専用で開くので上書き保存はできないし、
同じ名前を使って別名保存も怒られる。
なので、一旦別の名前で保存して、元のファイルを差し替える処理を考えた。
ファイルコピーは裏で行われるので、処理が終わったときに開いているブック名が違うので、
開いているブックをいったん閉じてから、元のブックを読み取り専用で開く
別のブックを開く処理を入れたので、
元のブックのフルパスを変数に格納して閉じるときに指定する必要がある。
参考にしたサイトは以下の３つ。
'読み取り専用を推奨
https://yumem.cocolog-nifty.com/excelvba/2020/05/post-5c964a.html
'読み取り専用の推奨を無視
https://www.limecode.jp/entry/utility/workbookopen-_ignorereadonlyrecommended
'マイクロソフト Save
https://learn.microsoft.com/ja-jp/dotnet/api/microsoft.office.tools.excel.workbook.saveas?view=vsto-2022
【今回実装した処理】
読み取り専用で開く処理
Workbooks.Open myFullName, ReadOnly:=True
書き込みパスワードを指定して保存する方法
ActiveWorkbook.SaveAs Filename:=バックアップ名, WriteResPassword:="ai" ', ReadOnlyRecommended:=True
ReadOnlyRecommendedをコメントアウトしているのは、パスワード入力後に読み取り専用を推奨されるから。
書き込みパスワード指定した場合は要らない。
ひとまず上記の内容のマクロが組めるかどうか試してみたところ、問題なく動作した。
残課題としては、ブックを開いてから保存マクロを実行するまでの間に
他の人が保存をした場合に困るというもの。
思いついた対策案（将来対応）
シートごとに更新日時のセルを用意して、更新がないシートのみ保存可能。
更新があったら・・・一時ファイルを開いた状態のまま元のファイルを開いてもう一回やってもらうか。。。
以下ソース。
Option Explicit
Sub 読み取り専用ファイルを上書き保存()
Dim バックアップ名 As String, ファイル名 As String, dEXT As String, pos As Long, BKUPpath As String, RC As Long, Savedate As Double
BKUPpath = ActiveWorkbook.Path & "\BKUP"
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(BKUPpath) Then
Else ' "フォルダが存在しない場合は作る"
FSO.CreateFolder BKUPpath
End If
ファイル名 = ActiveWorkbook.Name
pos = InStrRev(ファイル名, ".") '後方検索でHIT位置を返す 前方はInStr 関数
dEXT = Right(ファイル名, Len(ファイル名) - pos + 1) ' ピリオド付拡張子
Application.DisplayAlerts = False
Savedate = FileDateTime(ActiveWorkbook.FullName)
バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Savedate, "_yymmdd_hhmm") & "_BKUP" & dEXT
Dim myFullName As String: myFullName = ThisWorkbook.FullName
FSO.CopyFile myFullName, バックアップ名 'バックアップ取得
FSO.DeleteFile myFullName '元ファイルの削除
バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "_UPDT" & dEXT
ActiveWorkbook.SaveAs Filename:=バックアップ名, WriteResPassword:="ai" ', ReadOnlyRecommended:=True '一時ファイルとして保存
FSO.CopyFile バックアップ名, myFullName '一時ファイルを元のファイルとして扱う
Workbooks.Open myFullName, ReadOnly:=True
ThisWorkbook.Close
MsgBox "上書き保存に成功しました。"
Application.DisplayAlerts = True
Set FSO = Nothing
End Sub
PR
Comment