Userform & Tabelle ohne Nutzung nach Zeit schließe
08.03.2019 09:03:28
Tim
ich habe einen Code gefunden, der eine Userform schließen soll, wenn diese nach einer definierten Zeit ungenutzt gewesen ist. Problem an der Sache ist, das er für eine 32Bit Version ist. Gibt es eine Möglichkeit, dies ohne Berücksichtigung der Version auszuführen und zusätzlich die Tabelle mit schließen zu lassen?
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" ( _
ByRef hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long
Private Const gcClassnameMSExcel = "XLMAIN"
Private XLhWnd As Long
Public Sub prcTimerStart(sValue As Long)
XLhWnd = FindWindow(gcClassnameMSExcel, Application.Caption)
SetTimer XLhWnd, 0, sValue, AddrOf("prcTimer")
End Sub
Public Sub prcTimerStop()
KillTimer XLhWnd, 0
End Sub
Private Sub prcTimer(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
'Timer löschen
Call prcTimerStop
'Excelfile schliessen, Änderungen werden nicht gespeichert
ThisWorkbook.Close savechanges:=False
End Sub
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long, lResult As Long, lpfn As Long
Dim strID As String, strFuncNameUnicode As String
Const NO_ERROR = 0
AddrOf = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject 0 Then
lResult = GetFuncID(hProject, strFuncNameUnicode, strID)
If lResult = NO_ERROR Then
lResult = GetAddr(hProject, strID, lpfn)
If lResult = NO_ERROR Then: AddrOf = lpfn
End If
End If
End Function
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)
'eventl. vorhandenen Timer löschen
Call prcTimerStop
'Timer neu starten
Call prcTimerStart(60000) '= 1 Minute
End Sub