Thema: Uhr in Menüleiste

StandardModule: Modul1

Sub StartClock()
   StartClockinMenu
End Sub

Sub StopClock()
   StopClockinMenu
End Sub

StandardModule: Modul2

 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

Beiträge aus dem Excel-Forum zu den Themen API und Menue