Mappe öffnet sich nach schließen selbst
14.07.2020 18:47:48
wilo
Ich habe einen code der bei inaktivität nach 10 Minuten ein Meldungsfeld öffnet.
Dort kann ausgewählt werden ob die Mappe sich nach einer Minute schließen soll, ode
weitergearbeitet wird. Bei Ignoration dieses Meldungsfeldes wird nach einer Minute die Mappe gespeicherund und geschlossen.
Wenn jetzt aber mehrere Excel Mappen geöffnet sind öffnet sich später das Meldungsfeld und die Mappe wird wieder geöffnet.
Viell. kann mir jemand helfen ich komm einfach nicht drauf
Danke in Voraus
GLG
Hier der Code:
Klassenmodul:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Letztes Speicherdatum
Sheets("Stammdaten").Range("J1") = Now()
'Letzter Anwender
Sheets("Stammdaten").Range("I1") = Application.UserName
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Sheets("Maßnahmenkatalog").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True, AllowInsertingRows:=True, AllowFiltering:=True, _
AllowFormattingCells:=True
Application.Caption = ""
Application.OnTime dteCloseTime, "DoClose", , False
If Workbooks.Count = 1 Then
If Application.DisplayAlerts = False Then Application.DisplayAlerts = True
Application.Quit
End If
End Sub
Private Sub Workbook_Open()
Dim wks As Workshee
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
Set wks = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
'Debug.Print dteCloseTime
End Sub
Option Explicit
Const lngZeit = 10
Public dteCloseTime As Date, blnCloseNow As Boolean
Public Sub DoClose()
Dim strMsg As String
Dim WshShell As Object
Dim iReturn As Integer
Dim sMessage, sTitel As String
If blnCloseNow = False Then
strMsg = "Diese Datei wurde seit 10 Minuten nicht bearbeitet und" & vbCrLf & _
"wird bei weiterer Inaktivität in 1 Minute geschlossen!" & vbCrLf & _
"Soll die Datei in 1 Minute geschlossen werden?"
Set WshShell = CreateObject("WScript.Shell")
iReturn = WshShell.PopUp(strMsg, 5, ThisWorkbook.Name, _
vbYesNo + vbInformation + vbSystemModal)
Select Case iReturn
Case -1
blnCloseNow = True
dteCloseTime = Now + TimeSerial(0, 1, 0)
Application.OnTime dteCloseTime, "DoClose"
Case vbYes
blnCloseNow = True
dteCloseTime = Now + TimeSerial(0, 1, 0)
Application.OnTime dteCloseTime, "DoClose"
Case vbNo
blnCloseNow = False
dteCloseTime = Now + TimeSerial(0, lngZeit, 0)
Application.OnTime dteCloseTime, "DoClose"
End Select
Else
If ThisWorkbook.Saved = False Then
Application.DisplayAlerts = False
ThisWorkbook.Save 'Close savechanges:=True
Application.DisplayAlerts = True
ThisWorkbook.Close
Else
ThisWorkbook.Close
End If
End If
Debug.Print dteCloseTime
End Sub