Einfache Fortschrittsanzeige ohne Userform

[volti]

Hallo liebe Leserin, lieber Leser,

immer wieder taucht in Foren die Frage nach einer Fortschrittsanzeige auf, um dem User bei längeren Prozessen über den momentanen Stand der Abarbeitung zu informieren.

Neben der Nutzung der etwas unscheinbaren Excel-Statusbar bieten sich u.a. Fortschrittsanzeigen über eine Userform an. Hierzu findest Du ein Beispiel in der beigefügten Datei.

Eine weitere Möglichkeit ist die Verwendung eines Windows-Controls aus den CommonControls. Dieses ist ebenfalls in der Anlage mal angerissen.

Man kann sich aber auch über ein selbst erstelltes Windows-Fenster eine einfache Fortschrittsanzeige ohne Userform programmieren.
Im nachfolgend gezeigten Code möchte ich mal ein entsprechendes Beispiel zeigen.
Um den Code möglichst klein zu halten, erfolgt nur eine Anzeige. Buttons zum Abbruch etc. werden hier nicht verwendet, dadurch kann auf weiteren Code bzgl. einer WindowProc verzichtet werden.
Nach Ablauf des Prozesses wird der Laufbalken per VBA wieder ausgeschaltet.

Es versteht sich von selbst, dass man erst einmal seinen Code ablauftechisch optimiert.
Verbleibt dann eine nicht mehr reduzierbare, längere Prozesszeit (z.B. Öffnen und Bearbeitung vieler Dateien usw.) kann so ein Laufbalken sehr nützlich sein.
Da der Code zur Fortschrittsanzeige auch Zeit benötigt und den Prozess verlangsamt, sollte die Aktualisierung nicht zu oft passieren.

Hier der Code für die Windows-Fortschrittsanzeige.

Und nun viel Spaß beim Ausprobieren...

Code:

' Laufbalken (einfach Text), Nutzung der Dialogbox-Klasse, ohne _
 WindProc

Option Explicit
' Fenstererstellung und -handling
Private Declare PtrSafe Function CreateWindowExA Lib "user32" ( _
        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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, _
              lpParam As Any) As LongPtr
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" ( _
        ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
' Zeichnen/Schreiben
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function Rectangle Lib "gdi32" ( _
        ByVal hDC As LongPtr, _
        ByVal X1 As Long, ByVal Y1 As Long, _
        ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" ( _
        ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkColor Lib "gdi32" ( _
        ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" ( _
        ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function DrawTextA Lib "user32" ( _
        ByVal hDC As LongPtr, ByVal lpStr As String, _
        ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
        ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function CreatePen Lib "gdi32" ( _
        ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
        ByVal nHeight As Long, ByVal nWidth As Long, _
        ByVal nEscapement As Long, ByVal nOrientation As Long, _
        ByVal fnWeight As Long, ByVal fdwItalic As Long, _
        ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
        ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
        ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
        ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Const WS_EX_MYWINDOW = &H40008                   ' WS_EX_APPWINDOW + WS_EX_TOPMOST
Private Const WS_MYWINDOW = &H90C00000                   ' WS_CAPTION + WS_POPUP + WS_VISIBLE
Dim hDC As LongPtr, hFont As LongPtr
Dim hPen As LongPtr, hBrush As LongPtr
Dim R As RECT

Sub Laufbalken(sCaption As String, sText As String, Optional iProzent As Integer, _
                       Optional X As Long, Optional Y As Long)
  Dim hWnd As LongPtr, iLang As Long
  
  If sCaption = "" Then Exit Sub                         ' Kein gültiger Caption angegeben =>raus
  hWnd = FindWindowA("#32770", sCaption)                 ' Handle ermitteln
  If sText = "Destroy" Then                              ' Infobox schließen?
     If hWnd <> 0 Then DestroyWindow hWnd                ' Infobox schließen
     Exit Sub
  ElseIf hWnd = 0 Then                                   ' Neue Infobox starten
     If X = 0 Then X = (GetSystemMetrics(0) - 350) \ 2   ' X-Position
     If Y = 0 Then Y = (GetSystemMetrics(1) - 150) \ 2   ' Y-Position
     hWnd = CreateWindowExA( _
            WS_EX_MYWINDOW, "#32770", sCaption, WS_MYWINDOW, _
            X, Y, 350, 150, 0&, 0&, Application.HinstancePtr, ByVal 0&)
  End If
  
  hDC = GetDC(hWnd)                                      ' Device Context des Fensters holen

' Beschreibungstexte schreiben
  R.Left = 10: R.Top = 10: R.Bottom = 50: R.Right = 325  ' Schreibbereich festlegen
  SchreibeText sText, RGB(0, 0, 160), RGB(240, 240, 240), 2, 18, 6
  
' Laufbalkenrechtecke zeichnen
  ZeichneRechteck 0, vbWhite, R.Left, R.Bottom + 15, R.Right - 2, R.Bottom + 35
  If iProzent = 0 Or iProzent > 100 Then iProzent = 100
  iLang = R.Left + 3 + (iProzent / 100 * R.Right)        ' Balkenbreite berechnen
  If iLang > R.Right - 3 Then iLang = R.Right - 3        ' und Laufbalken zeichnen
  ZeichneRechteck 5, RGB(80, 255, 80), R.Left + 2, R.Bottom + 17, iLang, R.Bottom + 34

' Prozentanzeige im Laufbalken
  R.Left = 150: R.Top = 67: R.Bottom = 85                ' Schreibbereich festlegen
  SchreibeText iProzent & "%     ", vbBlack, 0, 1, 16, 6

' Aufräumen
  ReleaseDC hWnd, hDC                                    ' Device Context auflösen
End Sub

Sub ZeichneRechteck(iPen As Long, iBKColor As Long, _
                    L As Long, T As Long, B As Long, H As Long)
  hPen = CreatePen(iPen, 0, 0)                           ' Pen erstellen
  SelectObject hDC, hPen                                 ' Pen aktivieren
  hBrush = CreateSolidBrush(iBKColor)                    ' Pinsel erstellen
  SelectObject hDC, hBrush                               ' Pinsel aktivieren
  Rectangle hDC, L, T, B, H                              ' Rechteck zeichnen
  DeleteObject hBrush: DeleteObject hPen                 ' Pinsel und Pen löschen
End Sub

Sub SchreibeText(sText As String, iTxtColor As Long, iBKColor As Long, _
                 iBKMode As Long, iFH As Integer, iFB As Integer)
  SetTextColor hDC, iTxtColor                            ' Schriftfarbe
  SetBkColor hDC, iBKColor                               ' Hintergrundfarbe Textfeld
  SetBkMode hDC, iBKMode                                 ' Hintergrund ggf. transparent
  hFont = CreateFontA(iFH, iFB, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, "Arial")
  SelectObject hDC, hFont                                ' Font aktivieren
  If sText <> "" Then
     DrawTextA hDC, sText & Space(255), 255, R, &H10     ' Text ausgeben
  End If
  DeleteObject hFont                                     ' Font löschen
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Hallo und Achtung,

nachfolgend möchte ich noch eine Verbesserung für die Fortschrittsanzeige (API) bereitstellen.

Hierbei werden die erstellten Objekte (Pen, Pinsel und Font) vor dem Löschen aus dem Device Context (DC) wieder herausgezogen.
Eine reine Sicherheitsmaßnahme; beim mehrjährigen Betrieb der Fortschrittsanzeige ohne diese Maßnahme ist bei mir noch kein Fehler aufgetreten.

Trotzdem empfehle ich, die beiden Subs mit der u.a. Version auszutauschen.

PS: Die hier bereitgestellte Datei habe ich nicht angepasst.

Code:

Sub ZeichneRechteck(iPen As Long, iBKColor As Long, _
                    l As Long, T As Long, b As Long, h As Long)
  hPen = CreatePen(iPen, 0, 0)                           ' Pen erstellen
  hPen = SelectObject(hDC, hPen)                         ' Pen aktivieren
  hBrush = CreateSolidBrush(iBKColor)                    ' Pinsel erstellen
  hBrush = SelectObject(hDC, hBrush)                     ' Pinsel aktivieren
  Rectangle hDC, l, T, b, h                              ' Rechteck zeichnen
  DeleteObject SelectObject(hDC, hPen)                   ' Pen löschen
  DeleteObject SelectObject(hDC, hBrush)                 ' Pinsel löschen
End Sub

Sub SchreibeText(sText As String, iTxtColor As Long, iBKColor As Long, _
                 iBKMode As Long, iFH As Integer, iFB As Integer)
  SetTextColor hDC, iTxtColor                            ' Schriftfarbe
  SetBkColor hDC, iBKColor                               ' Hintergrundfarbe Textfeld
  SetBkMode hDC, iBKMode                                 ' Hintergrund ggf. transparent
  hFont = CreateFontA(iFH, iFB, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, "Arial")
  hFont = SelectObject(hDC, hFont)                       ' Font aktivieren
  If sText <> "" Then
     DrawTextA hDC, sText & Space(255), 255, R, &H10     ' Text ausgeben
  End If
  DeleteObject SelectObject(hDC, hFont)                  ' Font löschen
End Sub

_________
viele Grüße
Karl-Heinz