Hallo liebe VBA Profis,
ich brauche eine Zeitschaltuhr für Excel. In den Spalten A und B sollen für eine einstellbare Zeit der Reihe nach einzelne Zellen gelb und orange erscheinen. Nach Ablauf des Zeitintervalls sollen sie
wieder ganz normal weiß sein. Also Zelle A1 gelb Zeitintervall1 lang, dann Zelle B1 orange Zeitintervall2 lang, dann wieder A2 gelb Zeitintervall1 lang, B2 orange Zeitintervall2 usw. Die Uhr muss genau einstellbar sein (sollte am besten auch Millisekunden verarbeiten können). Der Rechner darf keine so hohen Resourcen verbrauchen wie z.B. bei DoEvents mittels Schleifendurchlauf oder so etwas. Nein, die Uhr sollte irgendwie durch die Windows API verwirklicht werden. Welcher Experte schafft das?
Danke für Eure Hilfe
Hallo Christa,
Code:
' **************************************************************
' Modul: mZellenkarussell Typ = Allgemeines Modul
' **************************************************************
Option Explicit
Dim lngZ As Long
Sub Schaltfläche1_BeiKlick()
Dim oSh As Button
If Not IsError(Application.Caller) Then
If lngZ > 0 Then
lngZ = 0
ActiveSheet.Buttons(Application.Caller).Text = "Timer starten"
Else
ActiveSheet.Buttons(Application.Caller).Text = "Timer stoppen"
lngZ = 1
Zellenkarussell
End If
End If
End Sub
Sub Zellenkarussell()
Dim lngColorindex(0 To 1) As Long
Static dblT As Double
Dim lngZeiten(0 To 1) As Long
Dim rngZellen As Range
StopTimer
Set rngZellen = Range("A1,B1,A2,B2,A3,B3,A4,B4,A5,B5,A6,B6,A7,B7,A8,B8,A9,B9")
rngZellen.Interior.ColorIndex = -4142
If lngZ > 0 Then
lngColorindex(0) = 6
lngColorindex(1) = 45
lngZeiten(0) = 200
lngZeiten(1) = 750
rngZellen.Areas(lngZ).Interior.ColorIndex = lngColorindex((lngZ - 1) Mod 2)
lngZ = lngZ + 1
If lngZ = rngZellen.Areas.Count + 1 Then
lngZ = 1
End If
StartTimer lngZeiten((lngZ - 1) Mod 2)
End If
End Sub
' **************************************************************
' Modul: mTimer Typ = Allgemeines Modul
' **************************************************************
Option Explicit
'geklaut von hier:
'http://www.ozgrid.com/forum/showthread.php?t=45676&s=c42fc798f4dbffaf1634b4da1b06829d&p=231662#post231662
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 m_TimerID As Long
'Note: The duration is measured in milliseconds.
' 1,000 milliseconds = 1 second
Public Sub StartTimer(ByVal Duration As Long)
'If the timer isn't already running, start it.
If m_TimerID = 0 Then
If Duration > 0 Then
m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent)
If m_TimerID = 0 Then
MsgBox "Timer initialization failed!"
End If
Else
MsgBox "The duration must be greater than zero."
End If
Else
MsgBox "Timer already started."
End If
End Sub
Public Sub StopTimer()
'If the timer is already running, shut it off.
If m_TimerID <> 0 Then
KillTimer 0, m_TimerID
m_TimerID = 0
Else
'MsgBox "Timer is not active."
End If
End Sub
Public Property Get TimerIsActive() As Boolean
'A non-zero timer ID indicates that it's turned on.
TimerIsActive = (m_TimerID <> 0)
End Property
Private Sub TimerEvent()
Zellenkarussell
'Debug.Print "Timer event fired: "; Format$(Now, "long time")
End Sub
Gestartet und gestoppt wird das per Schaltfläche aus den Formularsteuerelementen.
Während der Timer aktiv ist, darf keine Zelle bearbeitet werden, sonst fliegt Excel weg.
Gruß Uwe
Zunächst schon mal vielen Dank Uwe, aber das Programm läuft noch nicht.
An der Stelle
Public Sub StartTimer(ByVal Duration As Long)
stoppt mein Compiler und unterstreicht diese Programmzeile gelb.
Vielleicht liegt es daran, dass ich das Programm auf einer 64 Bit Version laufen lasse.
Keine Ahnung. Meine Kenntnisse reichen dafür leider nicht aus, aber
für die Portierbarkei auf 64 Bit muss in der Deklaration der Code auf jedenfall so geändert werden:
(jeweils PtrSafe vor Function schreiben, that's all)
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Ich bräuchte hier dringend nochmal Deine Hilfe lieber Uwe.
Hallo Christa,
teste es mal damit:
Code:
' windows api timer functions
#If VBA7 And WIN64 Then
' 64-bit
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, _
ByVal uElapse As LongLong, _
ByVal lpTimerFunc As LongLong) As LongLong
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal HWnd As LongLong, _
ByVal nIDEvent As LongLong) As LongLong
#Else
'32-bit
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
#End If
Gruß Uwe
Hallo Uwe,
leider keine Besserung. Das Problem liegt hier:
Public Sub StartTimer(ByVal Duration As Long) - Zeile wird v. Compiler gelb unterstrichen
'If the timer isn't already running, start it.
If m_TimerID = 0 Then
If Duration > 0 Then
m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent) - SetTime Blau hervorgehoben
Dazu erscheint die Meldung : Typen unverträglich
Hallo Christa,
ich nehme an, dass Du dieses Makro direkt ausführst? Das geht nicht, da es einen Parameter zur Übergabe erwartet. Du müsstest es also von einem anderen Makro aus starten und dabei den Parameter mitgeben.
Ich habe hier in der anhängenden Excel-Datei noch eine andere Lösung ausgearbeitet. Die Grundlage - eine Klasse - stammt vom vbarchiv. Dort erfolgte die Ausgabe des Timers in einem userform- Ich habe das jetzt so umgebaut, dass mit dem Timer die Zelle A1 abwechselnd in grün und blau eingefärbt wird. Du kannst während der Laufzeit auch im Blatt arbeiten - sollte doch etwas nicht funktionieren, ist die Lösung während der Bearbeitung eher nicht geeignet.
Der Timer wird bei Öffnen oder Aktivieren der Exceldatei oder Wechsel auf das Tabellenblatt Tabelle1 gestartet. Wechselst Du das Tabellenblatt, gehst in eine Andere Exceldatei oder schließt diese Datei, wird er beendet.
Auch hier vielen Dank für die Hilfe, aber die Datei stürzt leider schon beim Öffnen ab.
Vielleicht sollte man irgendetwas mit der folgenden Funktion bau
Application.OnTime iTimerSet, "Startzeit"
Eigenet sich vielleicht nicht für Millisekunden aber immerhin.
Hallo Christa,
sorry, hab jetzt erst mitbekommen, dass Du 64 bit Office gemeint hast. Die Datei läuft unter Office 32 bit in windows 64 bit.
Hallo Christa,
jetzt mal als OnTime-Variante.
Gruß Uwe
Lieber Uwe,
ja das Programm funktioniert. Auch der von Dir geschriebene Code ist elegant.
Doch schau dir mal die Zeitsteuerung an. Egal welche Werte man
angibt, irgendwie scheinen die geschalteten Zeiten nicht eingehalten zu
werden.