Excel schließen nach Timeout mit Countdown

[volti]

Liebe Leserin, liebe Leser,

manchmal möchte man Excel nach einer bestimmten Zeit automatisch schließen. Hierbei wäre es schön, wenn der User auch darüber informiert würde und ggf. auch noch die Möglichkeit hätte, den Schließenprozess abzuwenden.

Hier mal eine Idee zur Aufgabenstellung...

Es wird nach Ablauf einer bestimmten Zeit eine Msgbox angezeigt, in der ein Countdown abläuft. Während des Countdowns hat der User Zeit, die Msgbox zu schließen und Excel weiter aktiv zu lassen.
Ansonsten wird Excel bzw. die aktuelle Mappe automatisch beendet.

Code:

Option Explicit
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function MessageBoxA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, _
        ByVal wType As Long) As Long
Private Declare PtrSafe Function SetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function GetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, _
        ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
        
Private mhTimer As LongPtr, miRestzeit As Long
Private Const miTimeOut As Long = 10     ' in Sekunden

Private Sub CloseExcelNow()
' Anzeigen einer MsgBox mit CountDown
  
  mhTimer = SetTimer(0&, 0&, 1000, AddressOf SetMsgText)    ' Timer setzen
  MessageBoxA Application.hwnd, _
              "Das Programm schließt automatisch in " & miTimeOut & " Sekunden!", _
              "Schließen: " & ThisWorkbook.Name, vbExclamation Or vbModeless
  KillTimer 0&, mhTimer                                     ' Timer löschen

  If miRestzeit > 1 Then Exit Sub                           ' User hat Button geklickt
' Jetzt Excel bzw. Mappe schließen
  If Workbooks.Count = 1 Then
     If ThisWorkbook.Saved = False Then ThisWorkbook.Save   ' Mappe ggf. speichern
     Application.Quit                                       ' Excel beenden
  Else
     ThisWorkbook.Close True                                ' Nur Mappe schließen
  End If
End Sub

Private Sub SetMsgText()
  Dim i As Integer, sArr() As String, hDlg As LongPtr
  Dim sText As String * 255

  hDlg = GetActiveWindow                                    ' Handle der Dialogbox
  SetDlgItemTextA hDlg, 2, "Stopp Prozess"                  ' Buttontext setzen
  GetDlgItemTextA hDlg, 65535, sText, 255                   ' Messagetext holen
  sArr = Split(Left$(sText, InStr(sText, vbNullChar) - 1))  ' Messagetext splitten
  For i = 0 To UBound(sArr)
     If Val(sArr(i)) > 0 Then
        sArr(i) = sArr(i) - 1: miRestzeit = Val(sArr(i))    ' Restzeit anpassen
        DoEvents
        If sArr(i) < 1 Then PostMessageA hDlg, &H10, 0&, 0& ' &H10 = WM_CLOSE
        SetDlgItemTextA hDlg, 65535, ByVal Join$(sArr)      ' Messagetext neu setzen
     End If
   Next i

End Sub


Public Sub CloseExcel()
' Starte den Schließenprozess, Wartezeit 5 Minuten
  Application.OnTime Now + TimeSerial(0, 5, 0), "CloseExcelNow"
End Sub

_________
viele Grüße
Karl-Heinz