有VBA 的excel文件在关闭的情况下自动又打开是什么问题？怎么解决？

kenese

如题： 有VBA 的excel文件在关闭的情况下自动又打开是什么问题？怎么解决？


附上代码：



Public RunWhen As String
'每1200秒执行一次
Public Const cRunIntervalSeconds = 1200
Public Const cRunWhat = "status_check"
Sub StartTimer()
RunWhen = Application.WorksheetFunction.Text(cRunIntervalSeconds / 86400, "[hh]:mm:ss")
Application.OnTime EarliestTime:=Now() + TimeValue(RunWhen), Procedure:=cRunWhat, Schedule:=True
End Sub
Function GetPingResult(Host)
   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult As String
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      If strResult = "Connected" Then
        GetPingResult = "通"
      Else
        GetPingResult = "不通"
      End If
   Next
   Set objPing = Nothing
End Function

Sub status_check()
Dim arData As Variant
arData = Sheet8.Range("A1").CurrentRegion
For i = 2 To UBound(arData)
    arData(i, 3) = GetPingResult(arData(i, 2))
    arData(i, 4) = Now()
    DoEvents
Next
Sheet8.Range("A1").Resize(UBound(arData), UBound(arData, 2)) = arData
Call StartTimer
End Sub

kevinchengcw

关闭事件里把Ontime设定的内容取消掉

kenese

kevinchengcw 发表于 2024-9-25 16:11
关闭事件里把Ontime设定的内容取消掉

哪一段， 我不会 ？

ykcbf1100

kenese 发表于 2024-9-25 16:20
哪一段， 我不会 ？

上传附件看看，也有可能是宏编辑器里的引用问题，清除失效的引用问题就可能消失了。

kenese

附上附件， 求解

zjdh

把这句注销掉即可
Application.OnTime EarliestTime:=Now() + TimeValue(RunWhen), Procedure:=cRunWhat, Schedule:=True

kenese

zjdh 发表于 2024-9-25 17:10
把这句注销掉即可
Application.OnTime EarliestTime:=Now() + TimeValue(RunWhen), Procedure:=cRunWhat,  ...

这行删掉？对吗？

kenese

kenese 发表于 2024-9-25 17:15
这行删掉？对吗？

删掉之后数据就不更新了（要求在文件打开的情况下每隔20分钟更新一次的）

zjdh

的确是的，有一个笨办法，不改变宏，关闭文件时同时关闭Excel程序，若需要用Excel则再打开。

ynzsvt

1. Public RunWhen As Date
   
2. '每1200秒执行一次
   
3. Public Const cRunIntervalSeconds = 5
   
4. Public Const cRunWhat = "status_check"
   
5. 
   
6. Sub StartTimer()
   
7. RunWhen = Now() + cRunIntervalSeconds / 86400
   
8. Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True
   
9. End Sub
   
10. 
    
11. Sub status_check()
    
12. '干活的内容自己添加
    
13. StartTimer
    
14. End Sub
    
15. 
    
16. '名称 必选/可选 数据类型 说明
    
17. 'EarliestTime 必选 Variant 希望此过程运行的时间。
    
18. 'Procedure 必选 String 要运行的过程名。
    
19. 'LatestTime 可选 Variant 过程开始运行的最晚时间。例如，如果 LatestTime 参数设置为 EarliestTime + 30，且当到达 EarliestTime 时间时，由于其他过程处于运行状态而导致 Microsoft Excel 不能处于“就绪”、“复制”、“剪切”或“查找”模式，则 Microsoft Excel 将等待 30 秒让第一个过程先完成。如果 Microsoft Excel 不能在 30 秒内回到“就绪”模式，则不运行此过程。如果省略该参数，Microsoft Excel 将一直等待到可以运行该过程为止。
    
20. 'Schedule 可选 Variant 如果为 True，则预定一个新的 OnTime 过程。如果为 False，则清除先前设置的过程。默认值为 True。
    
21. Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
22. Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=False
    
23. End Sub

复制代码

注释下方事件代码注意位置。