Excel 如果屏幕/工作站被锁定，则自动保存并关闭工作簿（在共享中）

我们每天在工作中都会遇到这样的情况：团队成员从网络共享中打开Excel工作簿以更新工作簿，但在完成后忘记保存和关闭文件

当用户锁定工作站并离开办公桌，使同事无法修改共享excel工作簿（只读）时，就会出现问题

另外，出于安全考虑，每次离开办公桌前都要锁好你的工作站，我鼓励读者养成良好的网络卫生习惯

我怎样才能一劳永逸地解决这个问题

---

有人可能会说，在云中打开此类文档可能会解决问题，但这取决于文档中存储的内容的性质。

将excel文件另存为.xlsm，以便在工作簿中存储宏

转到：开发人员选项卡->Visual Basic

双击左侧窗格中的“此工作簿”

粘贴以下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

每次打开工作簿、每分钟保存一次工作以及仅在记录屏幕/工作站时才关闭工作簿时，都会触发此宏。如果需要，可以删除自动保存功能

学分：

---

将excel文件另存为.xlsm，以便在工作簿中存储宏

转到：开发人员选项卡->Visual Basic

双击左侧窗格中的“此工作簿”

粘贴以下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

每次打开工作簿、每分钟保存一次工作以及仅在记录屏幕/工作站时才关闭工作簿时，都会触发此宏。如果需要，可以删除自动保存功能

学分：

---

我的一些初始参数定义错误，在模块级别执行类似操作总是更好的

对于您的

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

---

我有一些初始参数定义错误，在模块级做这样的事情总是更好的

对于您的

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

---

@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

模块选项2（用于锁定屏幕）：

Public LastCalculate As Date'确保它位于其他宏的外部和上方
Const checkIntervalTime As String=“00:00:30”@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

模块选项2（用于锁定屏幕）：

Public LastCalculate As Date'确保它位于其他宏的外部和上方
Const checkIntervalTime As String=“00:00:30”'这有多危险！在我们的工作中，出于安全考虑，人们需要锁好自己的车站，即使只是为了喝咖啡。想象一下，有人正在进行更改，但还没有完全完成，更不用说想要进行更改，因为他犯了一些错误，只是在返回办公桌时发现其他人已经开始处理错误的文件。这就是说，如果这对你有效，这是一段很好的代码。要求员工锁定他们的计算机是一个非常好的政策！！不过，我会推荐一种不同的方法。为什么不设置一个全局
Lastchanged
变量，该变量在工作表计算或其他方面自动重置，并有一个
应用程序。运行
仅当35分钟或其他时间后没有计算发生时才运行保存并关闭。我确实喜欢锁的方法，但我认为这可能有点过头了。如果这不起作用，我稍后会回来演示。下面是应用程序的一个示例。运行方法：以此为例：@PGSystemTester将试用它。谢谢您的提示。@JvdV在本例中，工作簿将只附加文本记录，不涉及复杂的公式或其他过程。所以风险很小，这有多危险！在我们的工作中，出于安全考虑，人们需要锁好自己的车站，即使只是为了喝咖啡。想象一下，有人正在进行更改，但还没有完全完成，更不用说想要进行更改，因为他犯了一些错误，只是在返回办公桌时发现其他人已经开始处理错误的文件。这就是说，如果这对你有效，这是一段很好的代码。要求员工锁定他们的计算机是一个非常好的政策！！不过，我会推荐一种不同的方法。为什么不设置一个全局
Lastchanged
变量，该变量在工作表计算或其他方面自动重置，并有一个
应用程序。运行
仅当35分钟或其他时间后没有计算发生时才运行保存并关闭。我确实喜欢锁的方法，但我认为这可能有点过头了。如果这不起作用，我稍后会回来演示。下面是应用程序的一个示例。运行方法：以此为例：@PGSystemTester将试用它。谢谢你