Uhzeit und Lauftext geht das ?
12.05.2005 18:28:50
Torsten
Ich habe mal folgende Frage :
Kann man die u.a evt. irgenwie umändern so das Die Uhrzeit weiterläuft wenn die Laufschrift in der Statusleiste gestartet wird ?
Jetz habe ich das Problem das wenn ich das Makro für die Laufschrift in der Statusleiste starte, das dann die Uhr nicht mehr weiterläuft.
Hoffe mir kann hier jemand weiterhelfen, und evt. wenn das gehen sollte eine Lösung Bieten. Natürlich auch wenn das nicht Funzen sollte, wäre ich über einen Hinweis eben Dankbar.
_______________________________________________________________________________
Dieses Makro habe ich für Uhrzeit in Menueleiste
in Modul 1
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
Private ClockCBControl As CommandBarButton
Sub StartClockinMenu()
Set ClockCBControl = _
Application.CommandBars(1).Controls.Add( _
Type:=msoControlButton, Temporary:=True)
ClockCBControl.Style = msoButtonCaption
ClockCBControl.Caption = Format(Now, "Long Time")
fncWindowsTimer 1000
End Sub
Sub StopClockinMenu()
fncStopWindowsTimer
ClockCBControl.Delete
End Sub
Private Function fncWindowsTimer( _
TimeInterval As Long _
) As Boolean
Dim WindowsTimer As Long
WindowsTimer = 0
If Val(Application.Version) > 8 Then
WindowsTimer = SetTimer _
( _
hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf_cbkCustomTimer _
)
Else
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
ClockCBControl.Caption = Format(Now, "Long Time")
End Function
Private Function AddrOf _
( _
CallbackFunctionName As String _
) _
As Long
Dim aResult As Long
Dim CurrentVBProject As Long
Dim strFunctionID As String
Dim AddressOfFunction As Long
Dim UnicodeFunctionName As String
UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode)
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
aResult = GetFuncID _
( _
hProject:=CurrentVBProject, _
strFunctionName:=UnicodeFunctionName, _
strFunctionID:=strFunctionID _
)
If aResult = 0 Then
aResult = GetAddr _
( _
hProject:=CurrentVBProject, _
strFunctionID:=strFunctionID, _
lpfnAddressOf:=AddressOfFunction _
)
If aResult = 0 Then
AddrOf = AddressOfFunction
End If
End If
End If
End Function
Private Function AddrOf_cbkCustomTimer() As Long
AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer)
End Function
Private Function vbaPass(AddressOfFunction As Long) As Long
vbaPass = AddressOfFunction
End Function
_______________________________________________________________________________
Diese Makro habe ich für Lauftext in Statusleiste
In Modul 2
Option Explicit
Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000
Dim LaufbandExit As Integer
Sub LaufbandStart()
Dim OrStatus As String
Dim LaufText As String
Dim B As Range
Dim BZelle As Range
LaufbandExit = 0
OrStatus = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set B = Sheets("Lauftext").Range("A1:D10")
LaufText = String(130, " ")
For Each BZelle In Sheets("Lauftext").Range("A1:D10")
LaufText = LaufText & " " & BZelle.Text
Next BZelle
Application.StatusBar = LaufText
Do
Sleep 300 'Verzögerung in Millisekunden
LaufText = Right(LaufText, Len(LaufText) - 1) & Left(LaufText, 1)
Application.StatusBar = LaufText
DoEvents
If LaufbandExit = 1 Then
Application.StatusBar = False
Application.DisplayStatusBar = OrStatus
LaufbandExit = 0
Exit Sub
End If
Loop
End Sub
Sub LaufbandEnde()
LaufbandExit = 1
End Sub
P.S die Makros habe ich aus der Rechere
Gruß
Torsten