Excel-Standard

VBA (Makros)

Allgemein

Probleme mit Excel

Autor: Max Kaffl (Nepumuk) --- Aus Excel VBA - Gruppe: Verschiedenes

Stoppuhr in Excel

Autor: Max Kaffl (Nepumuk) - Erstellt: -- - Letzte Revision: --

Stoppuhr in Excel

Sie wollen einen Wettkampf stoppen, ihre Videos schneiden, oder was auch immer, und müssen dazu Zeiten, Millisekunden genau, in eine Tabelle eintragen. Kein Problem. Mit folgendem Code generieren sie eine eigene Symbolleiste, welche einer komfortablen Stoppuhr entspricht.

Die Funktion der Buttons:

· Start - Startet die Zeitmessung
· Stop - Beendet die Zeitmessung und gibt die gestoppte Zeit in der aktiven Zelle aus
· Pause - Unterbricht die Zeitmessung
· Lap - Gibt die Zwischenzeit in der aktiven Zelle aus
· Reset - Uhr zurücksetzen
· Preset - Zeit vorgeben, ab der die Zeitmessung beginnen soll

Die Zwischenzeit (Lap), kann auch mit der Tastenkombination Strg+y in die aktive, oder einem Doppelklick in eine beliebige Zelle, ausgegeben werden. Der Cursor spring, nach der Ausgabe der Zeit, automatisch eine Zelle nach unten.

Die benötigten Makros werden in drei Modulen untergebracht. Im Klassenmodul „DieseArbeitsmappe" befinden sich die Ereignisroutinen zum anlegen und löschen der Symbolleiste. Ein Standardmodul mit Namen „basCommandbar", in dem die Symbolleiste angelegt wird, sowie ein Standardmodul mit dem Namen „basClock", welches die Steuerung der Stoppuhr übernimmt.



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

Option Explicit

Private Sub Workbook_Activate()
 Call prc_CreateCommandBar
End Sub

Private Sub Workbook_Deactivate()
 Call prc_DeleteCommandBar
End Sub



' **************************************************************
' Modul: basCommandbar Typ = Allgemeines Modul
' **************************************************************

Option Explicit
Option Private Module

' Code Max Kaffl 2005

Public objCommandBar As CommandBar
Public objCommandBarButton(6) As CommandBarButton

Public Sub prc_CreateCommandBar()
 Call prc_DeleteCommandBar
 Set objCommandBar = CommandBars.Add(Name:="Stoppuhr", _
 Position:=msoBarFloating, Temporary:=True)
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(0), _
 enumType:=msoControlButton, varOnAction:="prc_Start", _
 varCaption:="Start", enumStyle:=msoButtonCaption, _
 varTipText:="starten")
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(1), _
 enumType:=msoControlButton, varOnAction:="prc_Stop", _
 varCaption:="Stop", enumStyle:=msoButtonCaption, _
 bolEnabled:=False, varTipText:="stoppen")
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(2), _
 enumType:=msoControlButton, varOnAction:="prc_Pause", _
 varCaption:="Pause", enumStyle:=msoButtonCaption, _
 bolEnabled:=False, varTipText:="anhalten")
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(3), _
 enumType:=msoControlButton, varOnAction:="prc_Lap", _
 varCaption:="Lap", enumStyle:=msoButtonCaption, _
 bolEnabled:=False, varTipText:="Zwischenzeit")
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(4), _
 enumType:=msoControlButton, varOnAction:="prc_Reset", _
 varCaption:="Reset", enumStyle:=msoButtonCaption, _
 bolEnabled:=False, varTipText:="zurücksetzen")
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(5), bolBeginGroup:=True, _
 enumType:=msoControlButton, varTipText:="Anzeige", _
 varCaption:="00:00:00,000", enumStyle:=msoButtonCaption)
 Call prcControlAdd(objCommandBar, _
 varControl:=objCommandBarButton(6), bolBeginGroup:=True, _
 enumType:=msoControlButton, varOnAction:="prc_Preset", _
 varCaption:="Preset", enumStyle:=msoButtonCaption, _
 varTipText:="Voreinstellung")
 With objCommandBar
 .Top = 150
 .Left = 100
 .Protection = msoBarNoChangeDock + msoBarNoChangeVisible _
 + msoBarNoCustomize + msoBarNoHorizontalDock _
 + msoBarNoResize + msoBarNoVerticalDock
 .Visible = True
 End With
End Sub

Public Sub prc_DeleteCommandBar()
 On Error Resume Next
 KillTimer lnghWnd, 0
 CommandBars("Stoppuhr").Delete
End Sub

Private Sub prcControlAdd( _
 ByRef objParent As Object, _
 Optional ByRef varControl As Variant, _
 Optional ByVal enumType As MsoControlType, _
 Optional ByVal varId As Variant, _
 Optional ByVal varBefore As Variant, _
 Optional ByVal varTemporary As Variant, _
 Optional ByVal bolBeginGroup As Boolean = False, _
 Optional ByVal varCaption As Variant, _
 Optional ByVal varFaceId As Variant, _
 Optional ByVal varOnAction As Variant, _
 Optional ByVal enumStyle As MsoButtonStyle, _
 Optional ByVal varTipText As Variant, _
 Optional ByVal enumState As MsoButtonState, _
 Optional ByVal varTag As Variant, _
 Optional ByVal enumLinkType As MsoCommandBarButtonHyperlinkType, _
 Optional ByVal bolEnabled As Boolean = True, _
 Optional ByVal bolVisible As Boolean = True, _
 Optional ByVal varWidth As Variant, _
 Optional ByVal varDropDownWidth As Variant, _
 Optional ByVal varDropDownLines As Variant)
 Dim cmbControl As CommandBarControl
 Select Case IIf(enumType, 1, 0) & IIf(IsMissing(varId), 0, 1) & _
 IIf(IsMissing(varBefore), 0, 1) & IIf(IsMissing(varTemporary), 0, 1)
 Case "0100": Set cmbControl = objParent.Controls.Add(ID:=varId)
 Case "0101": Set cmbControl = objParent.Controls.Add(ID:=varId, _
 Temporary:=varTemporary)
 Case "0110": Set cmbControl = objParent.Controls.Add(ID:=varId, _
 Before:=varBefore)
 Case "0111": Set cmbControl = objParent.Controls.Add(ID:=varId, _
 Before:=varBefore, Temporary:=varTemporary)
 Case "1000": Set cmbControl = objParent.Controls.Add(Type:=enumType)
 Case "1001": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 Temporary:=varTemporary)
 Case "1010": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 Before:=varBefore)
 Case "1011": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 Before:=varBefore, Temporary:=varTemporary)
 Case "1100": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 ID:=varId)
 Case "1101": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 ID:=varId, Temporary:=varTemporary)
 Case "1110": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 ID:=varId, Before:=varBefore)
 Case "1111": Set cmbControl = objParent.Controls.Add(Type:=enumType, _
 ID:=varId, Before:=varBefore, Temporary:=varTemporary)
 End Select
 With cmbControl
 .BeginGroup = bolBeginGroup
 If Not IsMissing(varCaption) Then .Caption = varCaption
 If Not IsMissing(varFaceId) Then .FaceId = varFaceId
 If Not IsMissing(varOnAction) Then .OnAction = varOnAction
 If enumStyle Then .Style = enumStyle
 If Not IsMissing(varTipText) Then .TooltipText = varTipText
 If enumState Then .State = enumState
 If Not IsMissing(varTag) Then .Tag = varTag
 If enumLinkType Then .HyperlinkType = enumLinkType
 .Enabled = bolEnabled
 .Visible = bolVisible
 If Not IsMissing(varWidth) Then .Width = varWidth
 If Not IsMissing(varDropDownWidth) Then _
 .DropDownWidth = varDropDownWidth
 If Not IsMissing(varDropDownLines) Then _
 .DropDownLines = varDropDownLines
 End With
 If Not IsMissing(varControl) Then Set varControl = cmbControl
 Set cmbControl = Nothing
End Sub



' **************************************************************
' Modul: basClock Typ = Allgemeines Modul
' **************************************************************

Option Explicit
Option Private Module

' Code Max Kaffl 2005

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
 ByVal lpClassName As String, _
 ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32" ( _
 ByVal hwnd As Long, _
 ByVal nIDEvent As Long, _
 ByVal uElapse As Long, _
 ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
 ByVal hwnd As Long, _
 ByVal nIDEvent As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Public lnghWnd As Long

Private lngStartTime As Long, lngPauseTime As Long
Private lngPresetTime As Long
Private blnPause As Boolean

Private Sub prc_Start()
 Dim intIndex As Integer
 lngStartTime = timeGetTime - lngPresetTime
 With Application
 .MacroOptions Macro:="prc_Lap", _
 HasShortcutKey:=True, ShortcutKey:="y"
 .OnDoubleClick = "prc_Lap"
 End With
 blnPause = False
 lngPresetTime = 0
 objCommandBarButton(0).Enabled = False
 For intIndex = 1 To 4
 objCommandBarButton(intIndex).Enabled = True
 Next
 objCommandBarButton(6).Enabled = False
 lnghWnd = FindWindow("XLMAIN", Application.Caption)
 SetTimer lnghWnd, 0, 1, AddressOf prc_Display
End Sub

Public Sub prc_Lap()
 ActiveCell.Value = fnc_strTime(timeGetTime - lngStartTime)
 ActiveCell.Offset(1, 0).Select
End Sub

Private Sub prc_Pause()
 If blnPause Then
 lngStartTime = lngStartTime + (timeGetTime - lngPauseTime)
 objCommandBarButton(3).Enabled = True
 SetTimer lnghWnd, 0, 1, AddressOf prc_Display
 Else
 lngPauseTime = timeGetTime
 objCommandBarButton(3).Enabled = False
 KillTimer lnghWnd, 0
 objCommandBarButton(5).Caption = fnc_strTime(timeGetTime - lngStartTime)
 End If
 blnPause = Not blnPause
End Sub

Private Sub prc_Stop()
 Dim intIndex As Integer
 If blnPause Then _
 lngStartTime = lngStartTime + (timeGetTime - lngPauseTime)
 ActiveCell.Value = fnc_strTime(timeGetTime - lngStartTime)
 KillTimer lnghWnd, 0
 For intIndex = 1 To 3
 objCommandBarButton(intIndex).Enabled = False
 Next
 objCommandBarButton(5).Caption = ActiveCell.Text
 ActiveCell.Offset(1, 0).Select
End Sub

Private Sub prc_Reset()
 Dim intIndex As Integer
 KillTimer lnghWnd, 0
 lngStartTime = 0
 objCommandBarButton(0).Enabled = True
 For intIndex = 1 To 4
 objCommandBarButton(intIndex).Enabled = False
 Next
 objCommandBarButton(5).Caption = "00:00:00,000"
 objCommandBarButton(6).Enabled = True
 With Application
 .MacroOptions Macro:="prc_Lap", _
 HasShortcutKey:=True, ShortcutKey:=""
 .OnDoubleClick = ""
 End With
End Sub

Private Sub prc_Preset()
 Dim vntInput As Variant
 Do
 vntInput = InputBox("Vorgebezeit im Format hh:mm:ss eingeben.", _
 "Eingabe", "00:00:00")
 If StrPtr(vntInput) = 0 Then Exit Sub
 If vntInput Like "##:##:##" And IsDate(vntInput) Then Exit Do
 MsgBox "Fehlerhafte Eingabe.", 48, "Hinweis"
 Loop
 lngPresetTime = CDbl(CDate(vntInput)) * 86400000
 objCommandBarButton(5).Caption = fnc_strTime(lngPresetTime)
End Sub

Private Sub prc_Display(ByVal hwnd As Long, ByVal nIDEvent As Long, _
 ByVal uElapse As Long, ByVal lpTimerFunc As Long)
 objCommandBarButton(5).Caption = fnc_strTime(timeGetTime - lngStartTime)
End Sub

Private Function fnc_strTime(ByVal lngTime As Long) As String
 Dim lngHour As Long, lngMinute As Long, lngSecond As Long
 lngHour = lngTime \ 3600000
 lngMinute = (lngTime Mod 3600000) \ 60000
 lngSecond = (lngTime Mod 3600000 Mod 60000) \ 1000
 lngTime = lngTime Mod 3600000 Mod 60000 Mod 1000
 fnc_strTime = Format(CStr(lngHour), "00") & ":" & _
 Format(CStr(lngMinute), "00") & ":" & _
 Format(CStr(lngSecond), "00") & "," & _
 Format(CStr(lngTime), "000")
End Function

Weitere Artikel der Gruppe: Verschiedenes Aus Excel VBA

Nach oben

rechte seite