AW: Abändern auf 1,3 Sekunden ? Profi bitte schauen
03.08.2013 01:05:17
fcs
Hallo Matze, hallo Albert,
fast alle Zeitfunktionen in Excel basieren auf ganzen Sekunden, so auch OnTime.
Wenn man Ereignisse in Bruchteilen von Sekunden verarbeiten will, dann muss man eine betriebssystemnahe Zeitfunktion verwenden.
Ein Grundproblem aller zeitabhängigen Ereignisprozeduren:
Excel darf zum Zeitpunkt der Ausführung nicht mit etwas anderem beschäftigt sein.
Andernfalls werden die Ereignisprozeduren verzögert oder nicht ausgeführt, oder es kommt es schnell zum Excel-/Systemabsturz wenn man in den zeitgesteuerten Prozeduren auf eine Fehlerbehandlung verzichtet.
In der Beispieldatei hab ich ein ursprünglich als Stoppuhr konzipiertes VBA-Projekt mal in einen Zähler umgewandelt.
https://www.herber.de/bbs/user/86696.xlsm
Gruß
Franz
Timer-Funktion aus Herber-Excel-Forum:
https://www.herber.de/forum/archiv/1260to1264/t1261770.htm#1261770
https://www.herber.de/bbs/user/80010.xlsm
'Code in einem allgemeinen Modul
'Erstellt unter WIndows Vista, MS Office 2010 Professional
'Erstellt: 2013-08-02
'Ersteller: fcs
Option Explicit
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Public lnghWnd As Long
Private bolZeit As Boolean, strNumberformat As String
Private lngStarttime As Long
Private wksTime As Worksheet, rngZiel As Range
Private lngCount As Long
Private lngStart As Long
Private Const dblZeitDiff As Double = 1.3 'Zeitdifferenz in Sekunden
Sub Zaehler_Start()
If lngStarttime > 0 Then
MsgBox "Zähler läuft schon! " & vbLf & "Bitte ggf. erst Zähler stoppen.", _
vbInformation + vbOKOnly, "Zähler erhöhen alle " & dblZeitDiff & " Sekunden"
Else
Set wksTime = ActiveSheet 'Tabellnblatt in dem hochgezählt werden soll
Set rngZiel = wksTime.Range("D5") 'Zelle mit Zähler
lngCount = 0 'Dieser Wert wird alle 1,3 Sekunden hochgezählt
If MsgBox("Soll laufende Zeit in rechter Nachbarzelle der Zählerzelle angezeigt werden?" _
, _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Zähler erhöhen alle " & dblZeitDiff & " Sekunden") = vbYes Then
bolZeit = True
strNumberformat = rngZiel.Offset(0, 1).NumberFormat
rngZiel.Offset(0, 1).NumberFormat = "#,##0.000"
Else
bolZeit = False
End If
lngStart = rngZiel.Value
lnghWnd = FindWindow("xlMain", vbNullString)
lngStarttime = timeGetTime
SetTimer lnghWnd, 0, 1, AddressOf proc_Display
End If
End Sub
Sub Zaehler_Stopp()
'Stoppt den Timer und setzt andere Werte zurück
If lngStarttime = 0 Then
MsgBox "Bitte Zähler erst starten.", _
vbInformation + vbOKOnly, "Zähler erhöhen alle " & dblZeitDiff & " Sekunden"
Else
If bolZeit = True Then
rngZiel.Offset(0, 1).NumberFormat = strNumberformat
bolZeit = False
End If
Set rngZiel = Nothing: Set wksTime = Nothing
KillTimer lnghWnd, 0
lngStarttime = 0
End If
End Sub
Private Sub proc_Display(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long)
'Diese Prozedur verarbeitet den Timer
Dim dblLaufZeit As Double
On Error GoTo Fehler 'zwingend erforderlich, sonst stürzt Excel bei jeder Gelegenheit ab
dblLaufZeit = (timeGetTime - lngStarttime) / 1000 'Laufzeit in Sekunden
If dblLaufZeit > lngCount * dblZeitDiff Then
With rngZiel
.Value = lngStart + lngCount
If bolZeit = True Then .Offset(0, 1) = dblLaufZeit
End With
Fehler:
lngCount = lngCount + 1
End If
End Sub