Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Zeitsteuerung mittels Windows API
#1
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
Antworten Top
#2
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


Angehängte Dateien
.xls   Zeitsteuerung mittels Windows API.xls (Größe: 38,5 KB / Downloads: 3)
Antworten Top
#3
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.
Antworten Top
#4
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
Antworten Top
#5
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
Antworten Top
#6
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.


Angehängte Dateien
.xlsm   APITimer-2013.xlsm (Größe: 27,89 KB / Downloads: 6)
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#7
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.
Antworten Top
#8
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.
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
[-] Folgende(r) 1 Nutzer sagt Danke an schauan für diesen Beitrag:
  • ChristaRohn
Antworten Top
#9
Hallo Christa,

jetzt mal als OnTime-Variante.

Gruß Uwe


Angehängte Dateien
.xls   Zeitsteuerung mittels OnTimeI.xls (Größe: 51,5 KB / Downloads: 2)
Antworten Top
#10
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.
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste