如果 Screen/Workstation 被锁定，自动保存并关闭工作簿（共享）
Auto save and close workbook (in a share) if Screen/Workstation is Locked
我们在工作中每天都会遇到的事情是，当团队成员从网络共享中打开 Excel 工作簿以更新工作簿时，他忘记保存并在完成后关闭文件。
当用户锁定他的工作站并离开他的办公桌时，他的同事无法修改共享的 excel 工作簿（只读），就会出现此问题。
P.S 出于安全原因，每次离开办公桌前锁定工作站是至关重要的，我鼓励 reader 养成这种良好的网络卫生习惯。
如何一劳永逸地解决这个问题？
有人可能会争辩说，在云中打开此类文档可能会解决问题，但这取决于文档中存储的内容的性质。
将 excel 文件另存为 .xlsm 以在工作簿本身中启用宏存储。
转到：开发人员选项卡 -> Visual Basic
双击：'This Workbook'，在左侧窗格中
粘贴以下VBA代码：
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
右键单击 VBA项目 -> 插入 -> 模块
粘贴以下VBA代码：
Sub Save1()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
If IsLocked(Environ$("computername")) > 0 Then
Workbooks("book1test.xlsm").Close SaveChanges:=True
End If
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
保存宏：Ctrl+s
此宏将在您每次打开工作簿时触发，每分钟保存一次您的工作，并且只有在您的 screen/workstation 被记录时才关闭工作簿。如果需要，您可以删除 auto-save 功能。
学分：
Check if computer is locked using VBscript
我有一些初始参数定义错误，在模块级别做这样的事情总是更好。
对于您的 ThisWorkbook 部分，只有此代码：
Private Sub Workbook_Open()
Call TheTimerMac
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call RestApplicationTimer
End Sub
然后在标准模块中插入以下代码。可以使用常量调整设置，看起来你明白了（顺便感谢 CDATE 函数——比 TimeValeu 短）
我还插入了几个音频警告，部分只是为了我自己的娱乐。你看起来很敏锐，如果你不喜欢他们，你可以用核武器攻击他们。
'STANDARD MODULE CODE
'Constants
'Time settings
Const idleTimeLIMIT As String = "00:35:00" '<---- Edit this to whatever timer you want (hour:min:sec)
Const checkIntervalTime As String = "00:01:00" '<---- this can be executed frequently as it has low overhead
'Set this variable TRUE to confirm the macro is working with popup messages
Const conFirmRunning As Boolean = False
Dim LastCalculate As Date 'Make sure this is outside and above the other macros
Option Private Module
Public Sub TheTimerMac()
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "TheTimerMac is running."
'Schedules application to execute below macro at set time.
Application.OnTime Now + CDate(checkIntervalTime), "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
'OPTIONAL Warning messages to be spoken
Const TenMinuteWarning As String = "Your file will save and close in approximately 10 minutes"
Const FiveMinuteWarning As String = "Your file will save and close in approximately 5 minutes"
Const OneMinuteWarning As String = "This is the last warning. Your file will save and close in a little over a minute."
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "AnyBodyWorking Macro is running."
If LastCalculate = 0 Then
'Won't close application if lastCalc hasn't been set
Call RestApplicationTimer
ElseIf Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Exit Sub 'not even sure if this is needed, but probably good to be sure
''Optional spoken warnings
ElseIf DateDiff("S", Now, LastCalculate) < 60 Then
Application.Speech.Speak OneMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 300 Then
Application.Speech.Speak FiveMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 600 Then
Application.Speech.Speak TenMinuteWarnin
End If
Call TheTimerMac
End Sub
Sub RestApplicationTimer()
LastCalculate = Now + CDate(idleTimeLIMIT)
End Sub
最后，我认为你可以稍微改进一下 locked 函数，如下所示，你可以将它包含在你的 if 语句中。
Function IsLocked() As Boolean
IsLocked = _
GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
Environ$("computername") & "\root\cimv2"). _
ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count > 0
End Function
@PGSystemTester 这是我让它工作的唯一方法：
在本手册中：
Public idleTIME As Date '<---- Edit this to whatever timer you want (hour:min:sec)
Private Sub Workbook_Open()
idleTIME = CDate("00:10:00")
LastCalculate = Now + idleTIME
Check
End Sub
Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
LastCalculate = Now + idleTIME
End Sub
在模块选项 1 中：
Public LastCalculate As Date
Const checkIntervalTime As String = "00:01:00"
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
模块选项 2（锁定屏幕）：
Public LastCalculate As Date 'Make sure this is outside and above the other macros
Const checkIntervalTime As String = "00:00:30" '<---- this can be frequent as it has low overhead
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Or (IsLocked("FIBRE-X") > 0) Then
'if nothing has happened in the last interval idleTime OR Screen is Locked... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
请问我有什么可以改进的吗？
我们在工作中每天都会遇到的事情是，当团队成员从网络共享中打开 Excel 工作簿以更新工作簿时，他忘记保存并在完成后关闭文件。
当用户锁定他的工作站并离开他的办公桌时，他的同事无法修改共享的 excel 工作簿（只读），就会出现此问题。
P.S 出于安全原因，每次离开办公桌前锁定工作站是至关重要的，我鼓励 reader 养成这种良好的网络卫生习惯。
如何一劳永逸地解决这个问题？
有人可能会争辩说，在云中打开此类文档可能会解决问题，但这取决于文档中存储的内容的性质。
将 excel 文件另存为 .xlsm 以在工作簿本身中启用宏存储。
转到：开发人员选项卡 -> Visual Basic
双击：'This Workbook'，在左侧窗格中
粘贴以下VBA代码：
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
右键单击 VBA项目 -> 插入 -> 模块
粘贴以下VBA代码：
Sub Save1()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
If IsLocked(Environ$("computername")) > 0 Then
Workbooks("book1test.xlsm").Close SaveChanges:=True
End If
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
保存宏：Ctrl+s
此宏将在您每次打开工作簿时触发，每分钟保存一次您的工作，并且只有在您的 screen/workstation 被记录时才关闭工作簿。如果需要，您可以删除 auto-save 功能。
学分：
Check if computer is locked using VBscript
我有一些初始参数定义错误，在模块级别做这样的事情总是更好。
对于您的 ThisWorkbook 部分，只有此代码：
Private Sub Workbook_Open()
Call TheTimerMac
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call RestApplicationTimer
End Sub
然后在标准模块中插入以下代码。可以使用常量调整设置，看起来你明白了（顺便感谢 CDATE 函数——比 TimeValeu 短）
我还插入了几个音频警告，部分只是为了我自己的娱乐。你看起来很敏锐，如果你不喜欢他们，你可以用核武器攻击他们。
'STANDARD MODULE CODE
'Constants
'Time settings
Const idleTimeLIMIT As String = "00:35:00" '<---- Edit this to whatever timer you want (hour:min:sec)
Const checkIntervalTime As String = "00:01:00" '<---- this can be executed frequently as it has low overhead
'Set this variable TRUE to confirm the macro is working with popup messages
Const conFirmRunning As Boolean = False
Dim LastCalculate As Date 'Make sure this is outside and above the other macros
Option Private Module
Public Sub TheTimerMac()
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "TheTimerMac is running."
'Schedules application to execute below macro at set time.
Application.OnTime Now + CDate(checkIntervalTime), "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
'OPTIONAL Warning messages to be spoken
Const TenMinuteWarning As String = "Your file will save and close in approximately 10 minutes"
Const FiveMinuteWarning As String = "Your file will save and close in approximately 5 minutes"
Const OneMinuteWarning As String = "This is the last warning. Your file will save and close in a little over a minute."
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "AnyBodyWorking Macro is running."
If LastCalculate = 0 Then
'Won't close application if lastCalc hasn't been set
Call RestApplicationTimer
ElseIf Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Exit Sub 'not even sure if this is needed, but probably good to be sure
''Optional spoken warnings
ElseIf DateDiff("S", Now, LastCalculate) < 60 Then
Application.Speech.Speak OneMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 300 Then
Application.Speech.Speak FiveMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 600 Then
Application.Speech.Speak TenMinuteWarnin
End If
Call TheTimerMac
End Sub
Sub RestApplicationTimer()
LastCalculate = Now + CDate(idleTimeLIMIT)
End Sub
最后，我认为你可以稍微改进一下 locked 函数，如下所示，你可以将它包含在你的 if 语句中。
Function IsLocked() As Boolean
IsLocked = _
GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
Environ$("computername") & "\root\cimv2"). _
ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count > 0
End Function
@PGSystemTester 这是我让它工作的唯一方法：
在本手册中：
Public idleTIME As Date '<---- Edit this to whatever timer you want (hour:min:sec)
Private Sub Workbook_Open()
idleTIME = CDate("00:10:00")
LastCalculate = Now + idleTIME
Check
End Sub
Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
LastCalculate = Now + idleTIME
End Sub
在模块选项 1 中：
Public LastCalculate As Date
Const checkIntervalTime As String = "00:01:00"
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
模块选项 2（锁定屏幕）：
Public LastCalculate As Date 'Make sure this is outside and above the other macros
Const checkIntervalTime As String = "00:00:30" '<---- this can be frequent as it has low overhead
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Or (IsLocked("FIBRE-X") > 0) Then
'if nothing has happened in the last interval idleTime OR Screen is Locked... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
请问我有什么可以改进的吗？