Běžící hodiny v Excelu

[mikel]

A zkusil jsi něco dělat v sešitě, když máš spuštěné makro? Asi to moc dobře nejde, že?
Aktualizace času co sekundu je hezká věc, dokud tě co sekundu nebude blokovat.

[Reklama]

[cukista]

Kód: Vybrat vše

Sub VlozCas()
   Cells(1,1) = Time()
   Application.OnTime EarliestTime:= Now + TimeValue("00:00:01"), Procedure:= "VlozCas"
   Cells(1,2) = Now + TimeValue("00:00:01")
End Sub

Sub Konec()
   Application.OnTime EarliestTime:= Cells(1, 2), Procedure:= "VlozCas",  Schedule:= false
End Sub


Tyhle dve procedury jsem vlozil do modulu sesitu, jeste jsem na list placnul dve tlacitka. Prvnim (nalinkovanym na proceduru VlozCas) se to spusti a v bunce A1 po cca sekunde se objevuje novy, aktualni cas. Bunka A2 je pomocna, pomoci ni se "Timer" vypina. Druhe tlacitko, nalikovane na proceduru Konec, casovac vypina... Nezabyval jsem se tim do vsech detailu, nicmene letmo vim, ze v Excelu lze pracovat normalne, lze normalne kopirovat a presouvat bunky. Lze taky normalne pracovat s Win (spoustet jine aplikace, prepinat se mezi nimi atd.). Funguje to dokonce i kdyz zamknu PC a nasledne odemknu...
Takze dle meho nazoru tenhle mikrokod resi presne pozadavek zadavatele...

[mikel]

Vypadá to dobře. Gratuluji.
Jak je vidět, tak nic není nemožné.

[Střelec 5]

Zdravím pánové,mám problém ale nevím kde je chyba. S počítačem to moc neumím a už vůbec ne s makry a excelem i když to zkouším. Našel jsem na tomto fóru tudle vynikající věc tj.čas do listu excelu přes makra, ale nějak se mi to nedaří. Zkopíroval jsem celé zadání do sešitu excelu a přiřadil tlačítka k makrum.Čas vloží ale hlásí to chybu.Vyzkoušel jsem vše co mě napadlo ,ale někde dělám chybu.

[mike007]

ta chyba je snad jasná,ne? Excelový dokument zkouška čas.xls nelze nalézt.

[mike007]

Jinak co se týče hodin v excelu, tak tady máte docela pěkné hodiny s odpočtem : http://www.bastleni.com/uploader/data/hodiny.zip Přepočet se dá zastavit nebo se dá v makru nastavit po jaké době se má sešit zaktualizovat. Opravdu pěkné.

To si někdo vyhrál. I love Excel too...

[X]

martinb:

autor: Jiří Číhař

1) pojmenujte buňku, ve které se má zapisovat čas, názvem - "hodiny"

2) zapiště do modulu listu kód pro spuštění časovače při aktivaci listu:

Private Sub Worksheet_Activate()
Call StartClock
End Sub

Private Sub Worksheet_Deactivate()
Call StopClock
End Sub

3) vložte do modulu kódu program... ( viz VBE)

----------------------------------------------------------------

Option Explicit

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

Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long

Private Declare Function GetCurrentVbaProject Lib "vba332.dll" _
Alias "EbGetExecutingProj" _
(hProject As Long) As Long

Private Declare Function GetFuncID Lib "vba332.dll" _
Alias "TipGetFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionID As String) As Long

Private Declare Function GetAddr Lib "vba332.dll" _
Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionID As String, _
ByRef lpfnAddressOf As Long) As Long

Private WindowsTimer As Long

Sub StartClock()
Range("hodiny").Value = Format(Now, "Long Time")
fncWindowsTimer 1000
End Sub
Sub StopClock()
fncStopWindowsTimer
End Sub

Private Function fncWindowsTimer(TimeInterval As Long) As Boolean
Dim WindowsTimer As Long
WindowsTimer = 0
'if we are in Excel2000 or above use the
'built-in AddressOf operator to get a pointer to the
'callback function
If Val(Application.Version) > 8 Then
WindowsTimer = SetTimer(hwnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf_cbkCustomTimer)
Else 'use K.Getz & M.Kaplan function to get a pointer
WindowsTimer = SetTimer(hwnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf("cbkCustomTimer"))
End If
fncWindowsTimer = CBool(WindowsTimer)
End Function

Private Function fncStopWindowsTimer()
KillTimer hwnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=WindowsTimer
End Function

Private Function cbkCustomTimer(ByVal Window_hWnd As Long, _
ByVal WindowsMessage As Long, _
ByVal EventID As Long, _
ByVal SYSTEMTIME As Long) As Long
Dim CurrentTime As String
On Error Resume Next
Range("hodiny").Value = Format(Now, "Long Time")
End Function


Private Function AddrOf(CallbackFunctionName As String) As Long
'AddressOf operator replacement for Office97 VBA
'Authors: Ken Getz and Michael Kaplan
'
'declaration of local variables
Dim aResult As Long
Dim CurrentVBProject As Long
Dim strFunctionID As String
Dim AddressOfFunction As Long
Dim UnicodeFunctionName As String
'
'convert the name of the function to Unicode system
UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode)
'
'if the current VBProjects exists...
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
'...get the function ID of the callback function, based on its
'unicode-converted name, in order to ensure that it exists
aResult = GetFuncID(hProject:=CurrentVBProject, _
strFunctionName:=UnicodeFunctionName, _
strFunctionID:=strFunctionID)
'if the function exists indeed ...
If aResult = 0 Then
'...get a pointer to the callback function based on
'the strFunctionID argument of the GetFuncID function
aResult = GetAddr(hProject:=CurrentVBProject, _
strFunctionID:=strFunctionID, _
lpfnAddressOf:=AddressOfFunction)
'if we've got the pointer pass it to the result
'of the function
If aResult = 0 Then
AddrOf = AddressOfFunction
End If
End If
End If
End Function

Private Function AddrOf_cbkCustomTimer() As Long
'Office97 VBE does not recognise the AddressOf operator;
'however, it does not raise a compile-error either...
AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer)
End Function

Private Function vbaPass(AddressOfFunction As Long) As Long
vbaPass = AddressOfFunction
End Function

[Střelec 5]

Jinak co se týče hodin v excelu, tak tady máte docela pěkné hodiny s odpočtem : http://www.bastleni.com/uploader/data/hodiny.zip Přepočet se dá zastavit nebo se dá v makru nastavit po jaké době se má sešit zaktualizovat. Opravdu pěkné.

To si někdo vyhrál. I love Excel too...

Todle je fakt dost dobrý odkaz.Děkuji.

[Střelec 5]

[quote="X"]martinb:

autor: Jiří Číhař

1) pojmenujte buňku, ve které se má zapisovat čas, názvem - "hodiny"

2) zapiště do modulu listu kód pro spuštění časovače při aktivaci listu:

Private Sub Worksheet_Activate()
Call StartClock
End Sub

Private Sub Worksheet_Deactivate()
Call StopClock
End Sub

3) vložte do modulu kódu program... ( viz VBE)

----------------------------------------------------------------


Todle s přílohou viz. v textu nahoře a dole .....vložte do modulu kódu program... ( viz VBE) ........................je na spuštění hodin?? Nějak mi to nefunguje zapnutí času,budete muset pánové mít se mnou více času.

[X]

Střelec 5: Bohužel, nemohu dostat soubor .xls do přílohy ani po přejmenování, takže příklad nebude ...

[Pavel123]

A co třeba takhle: (V buňce A1 je "=nyní()" formát je "h:mm:ss" v buňce B1 je počet sekund po které mají hodiny běžet. Makro sice běží po celou dobu ale s excelem se dá normálně pracovat.

Kód: Vybrat vše

Sub hodiny()
    Dim finish As Variant
    finish = Int(Timer)
    finish = finish + Range("B1").Value
    Do While finish > Timer
        DoEvents
        Range("A1").Calculate
    Loop
End Sub


[Střelec 5]

Střelec 5: Bohužel, nemohu dostat soubor .xls do přílohy ani po přejmenování, takže příklad nebude ...

Tak mi to prosím tě pošli jako přílohu.