Das Clever-Excel-Forum.de - Treffen
findet vom 15. - 17. September 2017 in Thüringen / Region Großer Inselsberg statt. Hotelbuchung ab sofort möglich.


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
to 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)
to 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.
to 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
to 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
to 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-2016)
to 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.
to 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-2016)
[-] Folgende(r) 1 Benutzer sagt Danke an schauan für diesen Beitrag:
ChristaRohn
to 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)
to 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.
to top


Möglicherweise verwandte Themen...
Thema Verfasser Antworten Ansichten Letzter Beitrag
  Ordner auswählen & eintragen in Makro mittels VBA tobisw 15 902 05.08.2016, 18:59
Letzter Beitrag: tobisw
  Automatische Formatierung mittels Makro ? alexander.liedauer 8 531 13.05.2016, 06:04
Letzter Beitrag: alexander.liedauer
  bestimmte Spalten kopieren mittels VBA chris2610 4 498 18.04.2016, 09:37
Letzter Beitrag: chris2610
  Eigene Formel in Excel Datenreihe einpflegen (mittels VBA?) chris2610 2 399 11.04.2016, 15:50
Letzter Beitrag: Fennek
  Daten mittels Makro in ein anderes Tabellenblatt übernehmen Chris-89 2 507 06.04.2016, 14:03
Letzter Beitrag: Chris-89
  Zeile ausfüllen mittels VBA VBA_noob 10 936 19.03.2016, 09:31
Letzter Beitrag: VBA_noob
  Alle Fundstellen mit Wildcards in einem String mittels eines Strings ausgeben Schülerin 18 1.741 03.03.2016, 18:57
Letzter Beitrag: snb
  String mittels links, rechts, teil aufsplitten Connor 12 925 11.02.2016, 12:44
Letzter Beitrag: Connor
  IDV2 Tag mittels VBA in Audiodateien reinschreiben kathrin-Flint 7 779 31.01.2016, 05:34
Letzter Beitrag: schauan
Question Verknüpfung zu Datei - Dateiname mittels Zellwert ändern hypnosefrosch 4 545 21.01.2016, 18:41
Letzter Beitrag: schauan

Gehe zu:


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