Zeitsteuerung mittels Windows API

[ChristaRohn]

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

[Kuwer]

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

[ChristaRohn]

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.

[Kuwer]

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

[ChristaRohn]

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

[schauan]

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.

[ChristaRohn]

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.

[schauan]

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.

[Kuwer]

Hallo Christa,

jetzt mal als OnTime-Variante.

Gruß Uwe

[ChristaRohn]

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.