| |
こんにちは。一夜明けて、よく見たら変な事してましたね^ ^;
■標準モジュール
Sub Auto_Open()
Dim st As String
Dim fn As Long
fn = FreeFile
With ThisWorkbook
If .ReadOnly Then
Open .Path & "\use.txt" For Input As #fn
Input #fn, st
Close #fn
MsgBox st & " Open"
.Close False
Else
Open .Path & "\use.txt" For Output As #fn
Print #fn, Application.UserName
Close #fn
SetAttr .FullName, vbReadOnly
End If
End With
End Sub
Sub Auto_Close()
With ThisWorkbook
If Not .ReadOnly Then SetAttr .FullName, vbNormal
End With
End Sub
Sub Cstm_Save()
With ThisWorkbook
SetAttr .FullName, vbNormal
Application.EnableEvents = False
.Save
Application.EnableEvents = True
SetAttr .FullName, vbReadOnly
End With
End Sub
Sub NewName_Save()
Dim NewNm As Variant
With ThisWorkbook
Do
NewNm = Application.GetSaveAsFilename _
(.Name, "Microsoft Excelブック,*.xls")
If VarType(NewNm) = vbBoolean Then Exit Sub
If Len(Dir(NewNm)) = 0 Then Exit Do
If MsgBox("同名ファイル在り。置き換えしますか？", vbYesNo) _
= vbYes Then Exit Do
Loop
SetAttr .FullName, vbNormal
Application.EnableEvents = False
Application.DisplayAlerts = False
.SaveAs NewNm
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
SetAttr NewNm, vbReadOnly
End Sub
■ThisWorkbookモジュール
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
If SaveAsUI Then
Call NewName_Save
Else
Call Cstm_Save
End If
End Sub
これくらいでいいかと思います。
ただ、OPEN中ファイルの属性変更に少し不安があるので、別案として
最初に開いた時に元ファイルを別名保存してテンポラリーファイル的な使い方をする。
その時元ファイルは読み取り専用に属性変更をする。
とすれば保存の度に属性変更する必要はなく、OpenとCloseの時だけ処理をすればいいですね^ ^
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
