有VBA的excel文件关闭后自动打开， 怎么修改代码 ？

kenese

以下这段VBA 代码的excel， 当文件关闭后， 过了一会儿, 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

ykcbf1100

求助要上附件，没有附件别人无法调试的。

lss001

'建议增加工作薄关闭事件

山菊花

关闭工作簿时，要清除OnTime过程。

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     If dSj = 0 Then Exit Sub
   
3.     Application.OnTime EarliestTime:=dSj, Procedure:=cRunWhat, Schedule:=False
   
4. End Sub

复制代码

kenese

已经上传附件

micch

用ontime的人真多， 写定时任务，一定要预先写好停止任务的代码，预设好在什么情况就停止定时任务

kenese

山菊花 发表于 2025-3-26 08:55
关闭工作簿时，要清除OnTime过程。

老师，  加在最后面吗？ VBA 不会

山菊花

kenese 发表于 2025-3-27 11:19
老师，  加在最后面吗？ VBA 不会

加在ThisWorkbook模块中，可下载附件看一下。