Anzeige
Archiv - Navigation
1252to1256
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Countdown

Countdown
Fritz_W
Hallo VBA-Experten,
ich bitte um Hilfe bei der Umsetzung folgenden Vorhabens:
Sollte beim Aktivieren des Tabellenblatts 'Tabelle1' im Tabellenblatt 'Einstellungen' in der Zelle A43 eine Zahl stehen, dann sollte - ausgehend von diesem Wert (die Zahl steht für die Zeiteinheit in Minuten) in Zelle X2 der Tabelle1 diese Zeit rückwärts bis 0 gezählt werden. Nach Ablauf der Zeit sollte in der Zelle Z2 die Zahl 1 erscheinen.
Beispiel:
In Tabelle 'Einstellungen' in Zelle A43 steht 10, dann sollte - gerechnet vom Aktivieren der 'Tabelle1' in Zelle X2 beginnend von 10 Minuten bzw. 600 Sekunden rückwärts bis 0 gezählt werden und von diesem Zeitpunkt an sollte in Z2 eine 1 stehen.
Im Voraus besten Dank für jede Hilfe.
mfg
Fritz

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Countdown
20.03.2012 20:21:16
Fritz_W
Hallo Hajo,
vielen Dank für den Hinweis.
Die Seite enthält eine Menge interessanter Beispiele.
Dennoch befürchte ich, dass ich ohne weitere Hilfe das nicht meinem Vorhaben gemäß anpassen kann.
Stell deshalb auf 'Frage noch hoffen'.
mfg
Fritz
AW: Countdown
20.03.2012 20:21:17
Fritz_W
Hallo Hajo,
vielen Dank für den Hinweis.
Die Seite enthält eine Menge interessanter Beispiele.
Dennoch befürchte ich, dass ich ohne weitere Hilfe das nicht meinem Vorhaben gemäß anpassen kann.
Stell deshalb auf 'Frage noch hoffen'.
mfg
Fritz
Anzeige
AW: Countdown
20.03.2012 21:23:20
Josef

Hallo Fritz,
füge im VBE ein Klassenmodul mit dem Namen "APITimer" ein und kopiere folgenden Code dort hinein.
' **********************************************************************
' Modul: APITimer Typ: Klassenmodul
' **********************************************************************

Option Explicit

' benötigte API-Deklarationen
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 uIDEvent As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal cb As Long)

Private Declare Function VirtualAlloc Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal flAllocationType As Long, _
  ByVal flProtect As Long) As Long

Private Const MEM_COMMIT As Long = &H1000&

Private Declare Function VirtualFree Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal dwFreeType As Long) As Long

Private Const MEM_DECOMMIT As Long = &H4000&

Private Const PAGE_EXECUTE As Long = &H10&
Private Const PAGE_EXECUTE_READ As Long = &H20&
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&

Private Const ASM_SIZE As Long = &HFF&

Private m_ptrCallback As Long
Private m_hdlTimer As Long
Private m_blnEnabled As Boolean
Private m_lngInterval As Long

Public Event Tick()

' muss erste öffentliche Methode in Interface sein!
' API Timer wird diese Methode aufrufen
Public Sub TimerCallback( _
    ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal idEvent As Long, ByVal dwTime As Long)

  
  RaiseEvent Tick
End Sub


' Aktiviert/Deaktiviert Timer (vgl. VB Intrinsic)
Public Property Get Enabled() As Boolean
  Enabled = m_blnEnabled
End Property


Public Property Let Enabled(ByVal blnValue As Boolean)
  If blnValue <> m_blnEnabled Then
    If blnValue Then
      m_hdlTimer = SetTimer(0, 0, IntervalMS, m_ptrCallback)
    Else
      KillTimer 0, m_hdlTimer
    End If
    m_blnEnabled = blnValue
  End If
End Property


' Bestimmt Interval, in dem Tick Event gefeuert wird
' (in Millisekunden)
Public Property Get IntervalMS() As Long
  IntervalMS = m_lngInterval
End Property


Public Property Let IntervalMS(ByVal lngMs As Long)
  m_lngInterval = lngMs
  
  If Enabled Then
    ' wird Interval geändert während Timer aktiv ist,
    ' muss er neu initialisiert werden
    Enabled = False
    Enabled = True
  End If
End Property


' Adresse erster öffentlicher Methode eines COM Interfaces ermitteln
Private Function GetFirstPublicMethod(ByVal obj As Object) As Long
  Dim pObj As Long
  Dim pVtbl As Long
  
  ' Adresse über VTable des Interfaces (IUnknown und IDispatch
  ' dort zuerst eingetragen, daher 7 Einträge = &H1C Bytes überspringen)
  CopyMem pObj, ByVal ObjPtr(obj), 4
  CopyMem pVtbl, ByVal pObj + &H1C, 4
  
  GetFirstPublicMethod = pVtbl
End Function


' Für ASM Callback genutzten Speicher freigeben
Private Sub FreeCallback(ByVal ptr As Long)
  VirtualFree ByVal ptr, ASM_SIZE, MEM_DECOMMIT
End Sub


' ASM Callback erstellen, das Timercallbacks an eine
' Methode der Klasse weiterleitet
Private Function CreateCallback(ByVal obj As Object, _
    ByVal addr As Long, ByVal params As Long) As Long

  
  Dim ptrMem As Long
  Dim ptrItr As Long
  Dim ptrNewAddr As Long
  Dim i As Long
  Dim j As Long
  
  ' ausführbaren Speicher vom System holen
  ' und Maschinencode reinschreiben
  ptrMem = VirtualAlloc(ByVal 0&, ASM_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  If ptrMem = 0 Then
    Err.Raise 12345, , "VirtualAlloc fehlgeschlagen!"
  End If
  
  ptrItr = ptrMem
  
  For i = 1 To params
    CopyMem ByVal ptrItr + 0, &H2474FF, 3 ' PUSH [ESP+imm8]
    CopyMem ByVal ptrItr + 3, params * 4, 1
    ptrItr = ptrItr + 4
  Next
  
  CopyMem ByVal ptrItr + 0, &H68, 1 ' PUSH imm32
  CopyMem ByVal ptrItr + 1, ObjPtr(obj), 4
  ptrItr = ptrItr + 5
  
  ptrNewAddr = addr - ptrItr - 5
  
  CopyMem ByVal ptrItr + 0, &HE8, 1 ' CALL rel32
  CopyMem ByVal ptrItr + 1, ptrNewAddr, 4
  ptrItr = ptrItr + 5
  
  CopyMem ByVal ptrItr + 0, &HC2, 1 ' RET imm16
  CopyMem ByVal ptrItr + 1, params * 4, 2
  
  CreateCallback = ptrMem
End Function


Private Sub Class_Initialize()
  m_ptrCallback = CreateCallback(Me, GetFirstPublicMethod(Me), 4)
End Sub


Private Sub Class_Terminate()
  If Enabled Then Enabled = False
  FreeCallback m_ptrCallback
End Sub


In das Modul von Tabelle1 kopierst du diesen Code.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private WithEvents Timer1 As APITimer

Private Sub Timer1_Tick()
  On Error Resume Next
  Range("X2") = Range("X2") - 1 / 86400
  If Range("X2") <= 0 Then
    Timer1.Enabled = False
    Range("X2") = 0
    Range("Z2") = 1
  End If
End Sub


Private Sub Worksheet_Activate()
  Set Timer1 = New APITimer
  With Sheets("Einstellungen").Range("A43")
    If IsNumeric(.Value) And .Value <> "" Then
      Timer1.IntervalMS = 1000
      Timer1.Enabled = True
      Range("X2") = .Value / 1440
      Range("Z2") = ""
    End If
  End With
End Sub


Private Sub Worksheet_Deactivate()
  On Error Resume Next
  Timer1.Enabled = False
End Sub



« Gruß Sepp »

Anzeige
AW: Countdown
20.03.2012 22:02:55
Fritz_W
Hallo Sepp,
hast mir wieder super geholfen, ganz herzlichen Dank!!
Viele Grüße
Fritz
@Sepp
21.03.2012 11:19:26
Fritz_W
Hallo Sepp,
ich würde gerne - in der gleichen Arbeitsmappe - zusätzlich folgendes erreichen:
Wenn in der Tabelle 'Einstellungen' statt in Zellle A43 eine Zahl in A42 (erneut als Zahl für Minuten) steht (in beiden Zellen steht aber gleichzeitig nie eine Zahl, falls das bedeutsam wäre), dann sollte - auch wieder ab Aktivieren des Tabellenblatts 'Tabelle1' - die Zeit gezählt werden (jetzt in Zelle X4) aber diesmal aufsteigend bis maximal bis zur in Zelle A42 eingegebenen Zeit. Die Zeit in Tabelle1X4 sollte vorher jedoch angehalten werden, wenn die Formel der Zelle Z4 (in der Tabelle1) den Wert 1 liefert.
Ich hoffe, mein Anliegen nachvollziehbar dargelegt zu haben.
Sollte die Umsetzung zu aufwändig oder aufgrund des 'bereits bestehenden Projekts' zu evtl. problematisch sein, dann lieber auf die Umsetzung verzichten, da der bisherige Code super läuft und ich damit auch schon etliches erreicht habe.
Nochmals vielen Dank für die (wie immer) hervorragende Unterstützng.
Viele Güße
Fritz
Anzeige
AW: @Sepp
21.03.2012 21:11:49
Josef

Hallo Fritz,
ersetze den Code im Modul von Tabelle1 durch folgenden.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private WithEvents Timer1 As APITimer

Private modus As Integer
Private lngT As Long

Private Sub Timer1_Tick()
  On Error Resume Next
  If modus = 1 Then
    If Range("Z4") <> 1 Then
      Range("X4") = Range("X4") + (Timer - lngT) / 86400
    Else
      Timer1.Enabled = False
    End If
  ElseIf modus = 2 Then
    Range("X2") = Range("X2") - (Timer - lngT) / 86400
    If Range("X2") <= 0 Then
      Timer1.Enabled = False
      Range("X2") = 0
      Range("Z2") = 1
    End If
  Else
    Timer1.Enabled = False
  End If
End Sub


Private Sub Worksheet_Activate()
  Set Timer1 = New APITimer
  With Sheets("Einstellungen")
    If IsNumeric(.Range("A42").Value) And .Range("A42").Value <> "" Then
      Timer1.IntervalMS = 1000
      Timer1.Enabled = True
      Range("X4") = 0
      modus = 1
      lngT = Timer
    ElseIf IsNumeric(.Range("A43").Value) And .Range("A43").Value <> "" Then
      Timer1.IntervalMS = 1000
      Timer1.Enabled = True
      Range("X2") = .Range("A43").Value / 1440
      Range("Z2") = ""
      modus = 2
      lngT = Timer
    Else
      Timer1.Enabled = False
    End If
  End With
End Sub


Private Sub Worksheet_Deactivate()
  On Error Resume Next
  Timer1.Enabled = False
End Sub



« Gruß Sepp »

Anzeige
AW: @Sepp
21.03.2012 21:34:49
Fritz_W
Hallo Sepp,
großartig, ganz herzlichen Dank
und beste Grüße
Fritz
AW: @Sepp - Zeittakt überprüfen
22.03.2012 13:13:57
Fritz_W
Hallo Sepp,
der neue Code liefert mir (bei beiden Varianten) nun einen "falschen Zeittakt". Eine Sekunde Zeiteinheit wird nun offensichtlich als Zeiteinheit von mehreren Sekunden wiedergegeben. Dadurch stoppt die eine (neue) Variante in der Regel nur, wenn die zweite Bedingung (Formel in Zelle Z4 liefert den Wert 1) eintritt.
Ich weiß nicht, ob das mit meiner speziellen Konfiguration zusammenhängt (Excel 2010 - Windows 7), ich vermute aber eher nein, da der alte Code diese Auffälligkeit nicht zeigte.
Füge mal eine Beispieldatei bei.
Im Voraus besten Dank für Deine Bemühungen
Beste Grüße
Fritz
https://www.herber.de/bbs/user/79501.xlsm
Anzeige
AW: @Sepp - Zeittakt überprüfen
22.03.2012 20:48:24
Josef

Hallo Fritz,
war wohl gestern schon zu spät, so sollte es laufen.
' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private WithEvents Timer1 As APITimer

Private modus As Integer
Private lngT As Long

Private Sub Timer1_Tick()
  On Error Resume Next
  If modus = 1 Then
    If Clng(Range("Z4")) <> 1 And Range("X4") < Sheets("Einstellungen").Range("A42") / 1440 Then
      Range("X4") = TimeSerial(0, 0, Timer - lngT)
    Else
      Timer1.Enabled = False
    End If
  ElseIf modus = 2 Then
    Range("X2") = (Sheets("Einstellungen").Range("A43").Value / 1440) - (Timer - lngT) / 86400
    If Range("X2") <= 0 Then
      Timer1.Enabled = False
      Range("X2") = 0
      Range("Z2") = 1
    End If
  Else
    Timer1.Enabled = False
  End If
End Sub



Private Sub Worksheet_Activate()
  Set Timer1 = New APITimer
  With Sheets("Einstellungen")
    If IsNumeric(.Range("A42").Value) And .Range("A42").Value <> "" Then
      Timer1.IntervalMS = 1000
      Timer1.Enabled = True
      Range("X4") = 0
      modus = 1
      lngT = Timer
    ElseIf IsNumeric(.Range("A43").Value) And .Range("A43").Value <> "" Then
      Timer1.IntervalMS = 1000
      Timer1.Enabled = True
      Range("X2") = .Range("A43").Value / 1440
      Range("Z2") = ""
      modus = 2
      lngT = Timer
    Else
      Timer1.Enabled = False
    End If
  End With
End Sub



Private Sub Worksheet_Deactivate()
  On Error Resume Next
  Timer1.Enabled = False
End Sub



« Gruß Sepp »

Anzeige
AW: @Sepp - Zeittakt überprüfen
22.03.2012 22:54:47
Fritz_W
Hallo Sepp,
jetzt läuft es einwandfrei.
Vielen Dank und schöne Grüße
Fritz

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige