Zurück zur Homepage

Progressbar (Fortschrittsanzeige) in der Statusbar

 Beispieldatei (ProgressBarStatusbar.zip 22 kB)  

Unter Punkt 10 habe ich eine Fortschrittsanzeige vorgestellt, welche die Statusleiste für alle möglichen grafischen Spielereien missbraucht.

Fortschrittsanzeige in Statusleiste

Möchte man die in Windows gewohnte Fortschrittsleiste realisieren, kann man eine OCX (Comctl32.ocx) in sein Projekt einbinden und dann dieses Objekt verwenden.

Es funktioniert aber auch ohne Verweis & Co., indem man die auf dem System registrierte Fensterklasse "msctls_progress32" zum Erzeugen eines neuen Fensters benutzt.
Dieses mit "CreateWindowEx" erzeugte Fenster muss aber selbst wieder zerstört werden. Wenn man auf Klick- oder andere Ereignisse reagieren möchte, muss man die Fensternachrichten abfangen, was unter Excel aber etwas problematisch ist. Glücklicherweise ist das für eine reine Anzeige aber auch nicht nötig.

Die vorgestellte Klasse "clsProgressbar" erzeugt solch ein Fenster und zeigt es an der Position der Statusbar an. Wird die Eigenschaft "DurchgezogenerBalken" gesetzt, so wird ein durchgehender Fortschrittsbalken erzeugt, ansonsten einer in der üblichen Darstellung.

Die auf True gesetzte Eigenschaft "WertAnzeigen" lässt links etwas Platz und dort wird der aktuelle wert angezeigt.

Wie folgt wird die Klasse benutzt:

 

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub cmdAnimation_Click()
Dim i             As Long
Dim k             As Long
Dim lngSchritt    As Long
Dim objProgress   As New clsProgressbar

With objProgress
   .Minimum = Me.Range(
"B1")
   .Maximum = Me.Range(
"B2")
   .WertAnzeigen = (Me.Range(
"B5") <> "")
   .DurchgezogenerBalken = (Me.Range(
"B4") <> "")
   lngSchritt = (.Maximum - .Minimum) / 100
   k = .Minimum
   
For i = 1 To 100
      .Wert = k
      Sleep 100
      k = k + lngSchritt
   
Next
End With
Application.StatusBar = 
False
End Sub

Private Sub cmdWert_Click()
Dim objProgress   As New clsProgressbar
With objProgress
   .Minimum = Me.Range(
"B1")
   .Maximum = Me.Range(
"B2")
   .WertAnzeigen = (Me.Range(
"B5") <> "")
   .Wert = .Minimum
   .DurchgezogenerBalken = (Me.Range(
"B4") <> "")
   .Wert = Me.Range(
"B3")
   Sleep 5000
End With
Application.StatusBar = 
False

End Sub

Nachfolgend die Klasse clsProgressbar:

 Option Explicit
Private Type RECT
   Left 
As Long
   Top 
As Long
   Right 
As Long
   Bottom 
As Long
End Type
Private Type PPBRANGE
   iLow 
As Integer
   iHigh 
As Integer
End Type
Private Declare Function GetWindowLong _
   
Lib "user32" Alias "GetWindowLongA" ( _
   
ByVal hwnd As Long, _
   
ByVal nIndex 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 GetWindow _
   
Lib "user32" ( _
   
ByVal hwnd As Long, _
   
ByVal wCmd 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 As LongByVal As Long, _
   
ByVal nWidth As LongByVal nHeight As Long, _
   
ByVal hWndParent As Long, _
   
ByVal hMenu As Long, _
   
ByVal hInstance As Long, _
   lpParam 
As Any _
   ) 
As Long
Private Declare Function SendMessage _
   
Lib "user32" Alias "SendMessageA" ( _
   
ByVal hwnd As Long, _
   
ByVal wMsg As Long, _
   wParam 
As Any, _
   lParam 
As Any _
   ) 
As Long
Private Declare Function DestroyWindow _
   
Lib "user32" ( _
   
ByVal hwnd As Long _
   ) 
As Long
Private Declare Function GetWindowRect _
   
Lib "user32" ( _
   
ByVal hwnd As Long, _
   lpRect 
As RECT _
   ) 
As Long
Private Const GWL_HINSTANCE = (-6)
Private Const GW_CHILD = 5&
Private Const PBS_SMOOTH = &H1
Private Const WS_VISIBLE = &H10000000
Private Const WS_CHILD = &H40000000
Private Const WM_USER = &H400
Private Const PBM_SETRANGE = (WM_USER + 1)
Private Const PBM_SETPOS = (WM_USER + 2)
Private Const PBM_DELTAPOS = (WM_USER + 3)
Private Const PBM_SETSTEP = (WM_USER + 4)
Private Const PBM_STEPIT = (WM_USER + 5)
Private Const PBM_SETRANGE32 = (WM_USER + 6)
Private Const PBM_GETRANGE = (WM_USER + 7)



Private mlngCurInstance    As Long
Private mlngStatusbar      As Long
Private mlngCreatedWindow  As Long
Private mlngLinks          As Long
Private mlngWert           As Long
Private mlngMaximum        As Long
Private mlngMinimum        As Long
Private mlngSchrittweite   As Long
Private mblnBalken         As Boolean
Private mblnWertAnzeigen   As Boolean

Private Sub DestroyMyWindow()
    DestroyWindow mlngCreatedWindow
    mlngCreatedWindow = 0
End Sub

Private Sub CreateProgressBar()
Dim lngIncrement     As Long
Dim udtGesamtgrösse  As RECT
Dim lngGesamtBreite  As Long
Dim lngGesamtHöhe    As Long
Dim lngStil          As Long
Dim i                As Currency

GetWindowRect mlngStatusbar, udtGesamtgrösse
With udtGesamtgrösse
   lngGesamtBreite = .Right - .Left
   lngGesamtHöhe = .Bottom - .Top

   DestroyMyWindow
   
   
   
   lngStil = WS_CHILD 
Or WS_VISIBLE
   
If mblnBalken Then
      lngStil = lngStil 
Or PBS_SMOOTH
   
Else
      lngStil = lngStil 
And Not PBS_SMOOTH
   
End If
   
   mlngCreatedWindow = CreateWindowEx(0, _
      
"msctls_progress32", vbNullString, _
      lngStil, _
      mlngLinks, 0, lngGesamtBreite - mlngLinks, lngGesamtHöhe, _
      mlngStatusbar, 0, mlngCurInstance, 
ByVal 0)
      
   
' Min-Max festlegen
   SendMessage mlngCreatedWindow, PBM_SETRANGE, 0, _
      
ByVal (mlngMaximum * &H10000) + mlngMinimum
      
   
' Schrittweite festlegen
   SendMessage mlngCreatedWindow, PBM_SETSTEP, 
ByVal mlngSchrittweite, 0
   
   
' Wert setzen
   SendMessage mlngCreatedWindow, PBM_SETPOS, 
ByVal mlngWert, 0&
   
End With
 
End Sub


Public Property Get Maximum() As Long
   Maximum = mlngMaximum
End Property
Public Property Let Maximum(ByVal vNewValue As Long)
   mlngMaximum = vNewValue
   SendMessage mlngCreatedWindow, PBM_SETRANGE, 0, _
      
ByVal (mlngMaximum * &H10000) + mlngMinimum
End Property

Public Property Get Minimum() As Long
   Minimum = mlngMinimum
End Property
Public Property Let Minimum(ByVal vNewValue As Long)
   mlngMinimum = vNewValue
   SendMessage mlngCreatedWindow, PBM_SETRANGE, 0, _
      
ByVal (mlngMaximum * &H10000) + mlngMinimum
End Property

Public Property Get Schrittweite() As Long
   Schrittweite = mlngSchrittweite
End Property
Public Property Let Schrittweite(ByVal vNewValue As Long)
   mlngSchrittweite = vNewValue
   SendMessage mlngCreatedWindow, PBM_SETSTEP, 
ByVal mlngSchrittweite, 0
End Property
Public Property Get WertAnzeigen() As Boolean
   Wert = mblnWertAnzeigen
End Property
Public Property Let WertAnzeigen(ByVal vNewValue As Boolean)
   mblnWertAnzeigen = vNewValue
End Property

Public Property Get Wert() As Long
   Wert = mlngWert
End Property
Public Property Let Wert(ByVal vNewValue As Long)
   mlngWert = vNewValue
   
If mlngLinks = 0 And mblnWertAnzeigen = True Then
      mlngLinks = 100
      CreateProgressBar
   
End If
   
If mlngLinks > 0 And mblnWertAnzeigen = False Then
      mlngLinks = 0
      CreateProgressBar
   
End If
   
If mblnWertAnzeigen Then Application.StatusBar = "Wert : " & mlngWert
   SendMessage mlngCreatedWindow, PBM_SETPOS, 
ByVal mlngWert, 0&
End Property

Public Property Get DurchgezogenerBalken() As Boolean
   DurchgezogenerBalken = mblnBalken
End Property
Public Property Let DurchgezogenerBalken(ByVal vNewValue As Boolean)
   mblnBalken = vNewValue
   CreateProgressBar
End Property

Private Sub Class_Terminate()
    DestroyMyWindow
End Sub

Private Sub Class_Initialize()
Dim lngApp  As Long
   
' Handle der Application. Neuerdings geht auch
   
' lngApp = Application.hwnd
   lngApp = FindWindowEx(0, 0, vbNullString, Application.Caption)
   
' Instance der Application. Neuerdings geht auch
   
' mlngCurInstance = Application.hInstance
   mlngCurInstance = GetWindowLong(lngApp, GWL_HINSTANCE)
   
' Statusbar finden
   mlngStatusbar = GetWindow(lngApp, GW_CHILD)
   
' Maximum festlegen
   mlngMaximum = 100
   
' Schrittweite festlegen
   mlngSchrittweite = 1
   
' Erzeugen
   CreateProgressBar
End Sub