工作簿指定时间无操作自动关闭，ontime事件，内含对话框定时关闭功能

any1009

有一个文件aaaaa.xlsm，加入了指定时间内无操作自动弹出对话框，若指定时间内仍无操作，就自动不保存关闭的功能。具体代码如下（设备限定，无法上传附件）：

1.模块一：

1. Public dingshirr(1 To 1, 1 To 2)
   
2. 
   
3. Declare PtrSafe Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long, ByVal dwTimeout As Long) As Long'对话框定时关闭
   
4. 
   
5. 
   
6. Sub jishi()
   
7. 
   
8.     Call qxdingshi
   
9. 
   
10.     jishiguanbi = TimeValue("00:00:10")
    
11.     jishiyanchang = TimeValue("00:01:00")
    
12. 
    
13.     dingshirr(1, 1) = Now + jishiguanbi
    
14.     dingshirr(1, 2) = dingshirr(1, 1) + jishiyanchang
    
15. 
    
16.     Call tjdingshi
    
17. End Sub
    
18. 
    
19. Sub qxdingshi()
    
20.     On Error Resume Next ' 防止没有设置定时事件时产生错误
    
21.         Application.OnTime dingshirr(1, 1), "closewb", dingshirr(1, 2), False
    
22.     On Error GoTo 0 ' 重置错误处理
    
23. End Sub
    
24. 
    
25. Sub tjdingshi()
    
26.     Application.OnTime dingshirr(1, 1), "closewb", dingshirr(1, 2), True
    
27. End Sub
    
28. 
    
29. Sub closewb()
    
30.     Dim xRet As Long         '定义对话框
    
31. 
    
32.     autoclosetime = 15000
    
33.     miaoshu = autoclosetime / 1000
    
34. 
    
35. '以下是对话框定时关闭
    
36.     msgboxstr = "您已长时间未进行任何操作！"
    
37.     msgboxstr = msgboxstr & vbCrLf & vbCrLf & "请选择是否继续使用？"
    
38.     msgboxstr = msgboxstr & vbCrLf & vbCrLf & "是：可以继续使用    否：自动不保存关闭"
    
39.     msgboxstr = msgboxstr & vbCrLf & vbCrLf & "此对话框将在 " & miaoshu & " 秒后自动关闭，aaaaa表也将自动不保存关闭。"
    
40.     msgboxstr = msgboxstr & vbCrLf & vbCrLf & "注意：是不保存关闭！！！"
    
41.     msgboxstr = msgboxstr & vbCrLf & "注意：是不保存关闭！！！"
    
42.     msgboxstr = msgboxstr & vbCrLf & "注意：是不保存关闭！！！"
    
43. 
    
44.     xRet = MessageBoxTimeout(0, msgboxstr, "友情提示", vbYesNo + vbInformation, 1, autoclosetime)
    
45. 
    
46.     Select Case xRet
    
47.     Case 32000
    
48.         Debug.Print "超时自动关闭"
    
49.         Call qxdingshi
    
50.         ThisWorkbook.Close SaveChanges:=False
    
51.     Case vbYes
    
52.         Debug.Print "选择""是""按钮"
    
53.         Call jishi
    
54.     Case vbNo
    
55.         Debug.Print "选择""否""按钮"
    
56.         Call qxdingshi
    
57.         ThisWorkbook.Close SaveChanges:=False
    
58.     End Select
    
59. '以上是对话框定时关闭
    
60. End Sub

复制代码

2.thisworkbook:

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Call qxdingshi
   
3. End Sub
   
4. 
   
5. Private Sub Workbook_Open()
   
6.     Call jishi
   
7. End Sub
   
8. 
   
9. Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   
10.     Call jishi
    
11. End Sub
    
12. 
    
13. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
14.     Call jishi
    
15. End Sub

复制代码

现在问题是，手动打开关闭aaaaa.xlsm，都没有问题，但是在其他文件内用vba打开aaaaa.xlsm这张表再关闭，ontime仍然会继续运行（即程序打开关闭aaaaa.xlsm后到设定时间还是会再次打开aaaaa.xlsm内ontime指定的程序）

3.其他文件打开代码：

1. Sub testtt()
   
2. 
   
3. 
   
4. Set wb1 = Workbooks.Open("D:\aaaaa.xlsm", ReadOnly:=True)
   
5.     With wb1.Sheets("Sheet1")
   
6.         x = .[A1].Value
   
7.     End With
   
8.     wb1.Close 0
   
9. Set wb1 = Nothing
   
10. 
    
11. MsgBox x
    
12. 
    
13. End Sub
    

复制代码

现在我是将aaaaa.xlsm内open的那段删掉，但这样对于aaaaa.xlsm来说，打开无操作功能就不完善了。

求大神解惑，这个该怎么破？

需要文件指定时间无操作自动关闭或对话框定时自动关闭功能的小伙伴，自行复制上面的代码就好，我都做了注释。

谢谢！~

any1009

自顶一下，有大神知道这是为什么吗？怎么修改才能不运行呢？

lss001

any1009 发表于 2024-10-26 21:16
自顶一下，有大神知道这是为什么吗？怎么修改才能不运行呢？

'请测试以下代码是否可行
Sub testtt()
Dim xapp As Application, wb1 As Workbook
Set xapp = CreateObject("Excel.Application") '新建程序
Set wb1 = xapp.Workbooks.Open(FileName:="D:\aaaaa.xlsm", ReadOnly:=True) '只读打开
xapp.Visible = True '显示

'您的其它代码

wb1.Close '关闭工作薄
xapp.Quit '退出程序
Set wb1 = Nothing '释放
Set xapp = Nothing
End Sub

any1009

非常感谢！问题已经解决。

所以原因是因为aaaaa.close虽然关掉了，但EXCEL进程未关闭？可是在关闭aaaaa.xlsm之前，不是把ontime事件给关掉了吗？为什么进程不关闭的话，还是会有这个事件呢？没关掉？手动打开关闭的时候又没有问题呀。

望解惑。

谢谢！~