Zurück zur Homepage

Fortschrittsanzeige als Uhr

Beim Spielen mit der API-Funktion CreateWindowExA habe ich mich gefragt, ob man mit einem so erzeugten Fenster überhaupt etwas anfangen kann. Man kann es je nach gewähler Klasse verschieben, vergrößern, verkleinern, minimieren, durch Auswahl verschiedener Stilflags ist es sogar möglich, das Aussehen und die Eigenschaften in weiten Bereichen den eigenen Bedürfnissen anzupassen. Steuerelemente können aber nicht so einfach darauf platziert werden, und selbst für ansonsten so triviale Dinge, wie einen einfachen Klick auf das Fenster mitzubekommen, muss man ungeahnte Hürden überwinden. Man kann zwar auch mit VBA unter Excel Fensternachrichten abhören und somit allerlei anstellen, aber das bremst Excel enorm aus und ist auch nicht sehr stabil.
Also bin ich auf die Idee gekommen, die erzeugten Fenster als Testfläche für GDI-Funktionen der Win32 API zu benutzen. Ohne eine konkrete Aufgabe macht das Testen aber nicht so richtig Spass, deshalb habe ich mal an eine einfache Analoguhr als Fortschrittsanzeige programmiert. Das Ganze ist zur besseren Handhabung in eine Klasse gepackt. Folgende Eigenschaften kann man setzen:
Fensterüberschrift (caption), Farbe des Fensters, Farbe des Ziffernblatts, Farbe der Uhrzeiger, Anzeige einer Digitaluhr, Position und Größe des Fensters.
Als anzuzeigender Wert kann eine Uhrzeit oder ein Wert zwischen Null und Hundert übergeben werden. Wird eine Uhrzeit übergeben, stellt der Code den Digitalwert als Zeitformat dar, andernfalls als Prozentwert.
Und hier nochmal eine Klarstellung. Der Code, der auf meinen Seiten zur Verfügung gestellt wird, kann frei verwendet werden. Eine Garantie für eine ordnungsgemäße Funktion kann und will ich aber nicht geben. Selbstverständlich habe ich den Code getestet und er hat sogar mindestens einmal funktioniert ;-). Eine Veröffentlichung bitte ich aber ohne Rückfrage zu unterlassen.
Wenn euch, wie ich sehr hoffe, unsere Seiten gefallen, würden wir uns über einen Eintrag ins Gästebuch freuen.

Beispieldatei (window.zip 59 KB)

'###########################################
'# In ein Modul
'###########################################

Option Explicit
Public MyNewWindow As New clsFortschrittsuhr

Public Sub Animation()
With MyNewWindow
    .Windowtext = "Animation Uhr"
    .PosTop = 200
    .PosLeft =200
    .Width = 200
    .Height = 200
    .CreateMyWindow
    .UhrRotanteil = 200
    .UhrGrünanteil =200
    .UhrBlauanteil = 200
    .ZeigerRotanteil = 0
    .ZeigerGrünanteil = 0
    .ZeigerBlauanteil = 0
    .WindowRotanteil = 150
    .WindowGrünanteil = 150
    .WindowBlauanteil = 150
    ZeigerBewegen
End With
End Sub


Public Sub ZeigerBewegen()
Static i As Double
With MyNewWindow
    If .hwnd_Window = 0 Then Exit Sub
    .Uhrzeit = i
    i = i + TimeSerial(0,5,0)
    If i > 0.5 Then i = 0: .DestroyMyWindow: Exit Sub
End With
Application.OnTime Now + TimeSerial(0, 0, 1), "ZeigerBewegen"
End Sub


 

'###########################################
'# Als Klasse clsFortschrittsuhr
'###########################################

Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hdc As Long, ByVal nIndex As Long) _
    As Long
Private Declare Function GetClientRect Lib "user32" _
    (ByVal hwnd As Long, lpRect As RECT) _
    As Long
Private Declare Function MoveToEx Lib "gdi32" _
    (ByVal hdc As Long, _
    ByVal x As Long, ByVal y As Long, _
    lpPoint As Any) _
    As Long
Private Declare Function Ellipse Lib "gdi32" _
    (ByVal hdc As Long, _
    ByVal X1 As Long, ByVal Y1 As Long, _
    ByVal X2 As Long, ByVal Y2 As Long) _
    As Long
Private Declare Function LineTo Lib "gdi32" _
    (ByVal hdc As Long, ByVal x As Long, _
    ByVal y As Long) _
    As Long
Private Declare Function DrawText Lib "user32" _
    Alias "DrawTextA" (ByVal hdc As Long, _
    ByVal lpStr As String, ByVal nCount As Long, _
    lpRect As RECT, ByVal wFormat As Long) _
    As Long
Private Declare Function SetTextColor Lib "gdi32" _
    (ByVal hdc As Long, ByVal crColor As Long) _
    As Long
Private Declare Function GetTextColor Lib "gdi32" _
    (ByVal hdc As Long) _
    As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
    Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) _
    As Long
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, ByVal hObject As Long) _
    As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
    (ByVal crColor As Long) _
    As Long

Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) _
    As Long
Private Declare Function FindWindowEx Lib "user32" _
    Alias "FindWindowExA" _
    (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, ByVal lpsz2 As String) _
    As Long
Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" _
    (ByVal hwnd As Long, ByVal nIndex As Long) _
    As Long

Private Declare Function CreateWindowEx Lib "user32" _
    Alias "CreateWindowExA" _
    (ByVal dwExStyle As Long, ByVal lpClassName As String, _
    ByVal lpWindowName As String, ByVal dwStyle As Long, _
    ByVal x As Long, ByVal y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal hWndParent As Long, ByVal hMenu As Long, _
    ByVal hInstance As Long, lpParam As Any) _
    As Long
Private Declare Function MoveWindow Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal x As Long, ByVal y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal bRepaint As Long) _
    As Long
Private Declare Function DestroyWindow Lib "user32" _
    (ByVal hwnd As Long) _
    As Long
Private Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) _
    As Long
Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hdc As Long) _
    As Long
Private Declare Function FillRect Lib "user32" _
    (ByVal hdc As Long, lpRect As RECT, _
    ByVal hBrush As Long) _
    As Long
Private Declare Function GetSysColor Lib "user32" _
    (ByVal nIndex As Long) _
    As Long

Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const WS_VISIBLE = &H10000000
Private Const WS_THICKFRAME = &H40000
Private Const WS_TABSTOP = &H10000
Private Const WS_SYSMENU = &H80000
Private Const WS_POPUP = &H80000000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MINIMIZE = &H20000000

Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const WS_GROUP = &H20000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_DLGFRAME = &H400000
Private Const WS_DISABLED = &H8000000
Private Const WS_CHILD = &H40000000
Private Const WS_CAPTION = &HC00000
Private Const WS_BORDER = &H800000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_OVERLAPPEDWINDOW = _
    (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or _
    WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_POPUPWINDOW = _
    (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const GWL_HINSTANCE = (-6)
Private Type RECT

    Left As Long
    Top As Long
    Right As Long
    Bottom As Long

End Type
Private Const LF_FACESIZE = 32
Private Const DT_CENTER = &H1
Private Const DT_BOTTOM = &H8
Private Const DT_LEFT = &H0
Private Const DT_RIGHT = &H2
Private Const DT_TOP = &H0
Private Const SM_CXSCREEN = 0
Private Const PS_SOLID = 0
Private Const GW_CHILD = 5&
Private Const FW_BOLD = 700&
Private Const FW_LIGHT = 300&
Private Const FW_MEDIUM = 500&
Private Const FW_NORMAL = 400&

Private Const FW_THIN = 100&
Private Type LOGFONT

    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte

End Type
Private ilngStyle As Long, iClass As String, ilngExStyle As Long
Private icurInstance As Long, iMyHwnd As Long
Private iTop As Long, iLeft As Long, iBreite As Long, iLänge As Long
Private ihwndCreatedWindow As Long, iFenstertext As String
Private iDefaultBackColor As Long, iWindowsDefaultFarbe As Boolean
Private FormRed As Byte, FormGreen As Byte, FormBlue As Byte
Private UhrRed As Byte, UhrGreen As Byte, UhrBlue As Byte
Private ZeigerRed As Byte, ZeigerGreen As Byte, ZeigerBlue As Byte
Private iWertAktuell As Double, iUhr As Boolean
Private iDigitaluhrAusblenden As Boolean

'####################################################
'Die Uhr auf den Fensterhintergrund malen
'####################################################

Private Sub UhrMalen(Wert As Double)
Dim mydc As Long, Grad As Single, PI As Double
Dim x As Long, y As Long, Brush As Long
Dim posx As Double, posy As Double
Dim Breite As Double, länge As Double
Dim Faktorx As Double, Faktory As Double
Dim Client As RECT, maxZeigerlänge As Double
'Aktuellen Wert zwischenspeichern
iWertAktuell = Wert
'DC ausleihen
mydc = GetDC(ihwndCreatedWindow)
    'Umrechnungsfaktor für logisches Koordinatensystem
    Faktorx = (GetDeviceCaps(mydc, LOGPIXELSX) * 20) / 1440
    Faktory = (GetDeviceCaps(mydc, LOGPIXELSY) * 20) / 1440
    'Clientgröße ermitteln
    GetClientRect ihwndCreatedWindow, Client
    'Fensterfarbe default oder benutzerdefiniert
    If iWindowsDefaultFarbe Then
        'default
        Brush = CreateSolidBrush(iDefaultBackColor)
    Else
        'benutzerdefiniert
        Brush = CreateSolidBrush(RGB(FormRed, FormGreen, FormBlue))
    End If
    'Clientbereich neu malen
    FillRect mydc, Client, Brush
    'Pinsel zerstören
    DeleteObject Brush
    'Breite Clientbereich erechnen
    Breite = (Client.Right - Client.Left)
    'Länge Clientbereich erechnen
    länge = (Client.Bottom - Client.Top)
    'Pinselfarbe Uhr
    Brush = CreateSolidBrush(RGB(UhrRed, UhrGreen, UhrBlue))
    'Pinsel in DC stellen
    SelectObject mydc, Brush
    'Ellipse in Brushfarbe malen, so groß wie der Clientbereich
    'Logisches Koordinatensysten
    Ellipse mydc, 0, 0, Breite, länge
    'Pinsel zerstören
    DeleteObject Brush
    'Pinselfarbe Zeiger
    Brush = CreateSolidBrush(RGB(ZeigerRed, ZeigerGreen, ZeigerBlue))
    'Mittelpunkt ermitteln
    x = Breite / 2
    y = länge / 2
    'maximale Zeigerlänge auf kleinste Dimension
    If x < y Then
        maxZeigerlänge = x
    Else
        maxZeigerlänge = y
    End If
    'Startpunkt auf den Mittelpunkt
    MoveToEx mydc, x, y, ByVal 0&
    'Zeigerendpunkt Stunde berechnen
    PI = 4 * Atn(1)
    Grad = 90 - 360 * Wert * 2
    'Grad * (PI / 180) weil Bogenmaß gebraucht wird
    posx = Cos(Grad * (PI / 180)) * maxZeigerlänge / 2
    posy = Sin(Grad * (PI / 180)) * maxZeigerlänge / 2
    x = Breite / 2 + posx
    y = länge / 2 - posy
    'Zeiger malen
    LineTo mydc, x, y
    'Mittelpunkt ermitteln
    x = Breite / 2
    y = länge / 2
    'Startpunkt auf den Mittelpunkt
    MoveToEx mydc, x, y, ByVal 0&
    'Zeigerendpunkt Minute berechnen
    Grad = 90 - 360 * (1 / 60) * Minute(Wert)
    'Grad * (PI / 180) weil Bogenmaß gebraucht wird
    posx = Cos(Grad * (PI / 180)) * maxZeigerlänge
    posy = Sin(Grad * (PI / 180)) * maxZeigerlänge
    x = Breite / 2 + posx
    y = länge / 2 - posy
    'Zeiger malen
    LineTo mydc, x, y
    'Pinsel zerstören
    DeleteObject Brush
    TextInDC mydc, Client
'DC zurückgeben
ReleaseDC ihwndCreatedWindow, mydc
End Sub


Private Sub TextInDC(DC As Long, pos As RECT)

Dim udtSchriftart As LOGFONT
Dim udtRahmenText As RECT
Dim Textfarbe As Long, Schriftdicke As Long
Dim myText As String, lngFont As Long, Höhe As Long
If iDigitaluhrAusblenden Then Exit Sub
Höhe = (pos.Bottom - pos.Top) / 10
With udtRahmenText
    .Left = 0
    .Top = pos.Bottom - ((pos.Bottom - pos.Top) / 5)
    .Right = pos.Right
    .Bottom = pos.Bottom - 10
End With
With udtSchriftart
    .lfItalic = False
    .lfStrikeOut = False
    .lfUnderline = False
    .lfHeight = Höhe * -1
    .lfWeight = FW_BOLD
End With
'Font erzeugen
lngFont = CreateFontIndirect(udtSchriftart)
SelectObject DC, lngFont
If iUhr Then
    myText = Format(iWertAktuell, "hh:mm")
Else
    myText = Format(iWertAktuell * 200, "0") & " %"
End If
SetTextColor DC, vbRed 'Textfarbe
'Text malen
DrawText DC, myText, _
    Len(myText), _
    udtRahmenText, _
    DT_CENTER
DeleteObject lngFont
End Sub


'####################################################
'Digitaluhr ausblenden
'####################################################

Public Property Let Digitaluhr_Ausblenden(ByVal vNewValue As Boolean)
    iDigitaluhrAusblenden = vNewValue
End Property

'####################################################
'Farben Hintergrund
'####################################################

Public Property Let WindowDefault(ByVal vNewValue As Boolean)
    iWindowsDefaultFarbe = vNewValue
End Property
Public Property Let WindowRotanteil(ByVal vNewValue As Byte)

    FormRed = vNewValue
End Property
Public Property Let WindowGrünanteil(ByVal vNewValue As Byte)

    FormGreen = vNewValue
End Property
Public Property Let WindowBlauanteil(ByVal vNewValue As Byte)

    FormBlue = vNewValue
End Property


'####################################################
'Farben Uhr
'####################################################

Public Property Let UhrRotanteil(ByVal vNewValue As Byte)
    UhrRed = vNewValue
End Property
Public Property Let UhrGrünanteil(ByVal vNewValue As Byte)

    UhrGreen = vNewValue
End Property
Public Property Let UhrBlauanteil(ByVal vNewValue As Byte)

    UhrBlue = vNewValue
End Property


'####################################################
'Farben Zeiger
'####################################################

Public Property Let ZeigerRotanteil(ByVal vNewValue As Byte)
    ZeigerRed = vNewValue
End Property
Public Property Let ZeigerGrünanteil(ByVal vNewValue As Byte)

    ZeigerGreen = vNewValue
End Property
Public Property Let ZeigerBlauanteil(ByVal vNewValue As Byte)

    ZeigerBlue = vNewValue
End Property


'####################################################
'Caption, bei anderen Klassen auch Text im Fenster
'####################################################

Public Property Let Windowtext(ByVal vNewValue As String)
    iFenstertext = vNewValue
End Property


'####################################################
'Fensterhandle, Instanzhandle
'####################################################

Public Property Get hwnd_App() As Long
    hwnd_App = iMyHwnd
End Property
Public Property Get hinst_App() As Long

    hinst_App = icurInstance
End Property
Public Property Get hwnd_Window() As Long

    hwnd_Window = ihwndCreatedWindow
End Property

'####################################################
'Fensterposition festlegen
'####################################################

Public Property Let PosLeft(ByVal vNewValue As Long)
    iLeft = vNewValue
End Property
Public Property Let PosTop(ByVal vNewValue As Long)

    iTop = vNewValue
End Property
Public Property Let Width(ByVal vNewValue As Long)

    iBreite = vNewValue
End Property
Public Property Let Height(ByVal vNewValue As Long)

    iLänge = vNewValue
End Property


'####################################################
'Werte übergeben
'####################################################

Public Property Let Uhrzeit(ByVal vNewValue As Date)
    iUhr = True
    UhrMalen (TimeSerial(Hour(vNewValue) Mod 12, Minute(vNewValue), Second(vNewValue)))
End Property
Public Property Let Prozent(ByVal vNewValue As Date)

    iUhr = False
    UhrMalen ((vNewValue Mod 100) / 200)
End Property


'####################################################

Public Sub DestroyMyWindow()
    DestroyWindow ihwndCreatedWindow
    ihwndCreatedWindow = 0
End Sub


Public Sub RefreshMyWindow()

    UhrMalen iWertAktuell
End Sub


Public Sub CreateMyWindow()

DestroyMyWindow
ihwndCreatedWindow = CreateWindowEx( _
    ilngExStyle, iClass, iFenstertext, ilngStyle, _
    iLeft - 1, iTop, iBreite, iLänge, _
    iMyHwnd, 0&, icurInstance, ByVal 0&)
MoveWindow ihwndCreatedWindow, iLeft + 1, iTop, iBreite, iLänge, 1&
End Sub


Private Sub Class_Terminate()

    DestroyMyWindow
End Sub


Private Sub Class_Initialize()

    'Handle der Application
    iMyHwnd = FindWindowEx(0, 0, vbNullString, Application.Caption)
    'Instance der Application
    icurInstance = GetWindowLong(iMyHwnd, GWL_HINSTANCE)
    'Fensterklasse festlegen
    iClass = "#32770"
'    iClass = "button"
'    iClass = "static"
'    iClass = "edit"

    'Stil festlegen
    ilngStyle = WS_POPUPWINDOW Or WS_VISIBLE
    ilngStyle = ilngStyle Or WS_OVERLAPPEDWINDOW
    'Defaultfarbe Fenster ermitteln
    iDefaultBackColor = GetSysColor(COLOR_BTNFACE)
    'Fenster in Defaultfarbe malen
    iWindowsDefaultFarbe = True
    'Farbanteile Fenster
    FormRed = iDefaultBackColor And &HFF&
    FormGreen = iDefaultBackColor \ &H100& And &HFF&
    FormBlue = iDefaultBackColor \ &H10000 And &HFF&
    'Farbanteile Uhr ( weiß &HFFFFFF )
    UhrRed = &HFF
    UhrGreen = &HFF
    UhrBlue = &HFF
    'Fensterposition
    iTop = 100: iLeft = 100
    iBreite = 200: iLänge = 200
    'Digitalanzeige als Uhrzeit, nicht als Prozentwert
    iUhr = True
End Sub