Attribute VB_Name = "Fortschritt"
'von Michael Schwimmer:
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal szClass$, _
ByVal szTitle$) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nmaxCount _
As Long) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function FillRect& Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long)
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const PS_SOLID = 0
Private Const GW_CHILD As Integer = 5
Private Const GW_HWNDFIRST As Integer = 0
Private Const GW_HWNDNEXT As Integer = 2
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Sub Fortschritt(ByVal BreiteProzent)
Static hPinsel&
Dim hFenster&, lngDcFenster&, strKlassenname$
Dim lngRück&, udtFenstergröße As RECT
Dim GesamtBreite, lngBreite&, lngGesamtHöhe&
Dim lngFortschrittsleiste&, lngFarbe&
'Hier kann die Farbe festgelegt werden
lngFarbe = RGB(255, 0, 0)
strKlassenname = String(256, 0)
'*****Fenster Statusleiste finden*****
hFenster = FindWindow("XLMAIN", Application.Caption)
hFenster = GetWindow(hFenster, GW_CHILD)
lngRück = GetClassName(hFenster, strKlassenname, 255)
strKlassenname = Left$(strKlassenname, lngRück)
If strKlassenname <> "EXCEL4" Then Exit Sub
'*****Größe Festlegen*****
lngRück = GetWindowRect(hFenster, udtFenstergröße)
GesamtBreite = udtFenstergröße.Right - udtFenstergröße.Left
lngGesamtHöhe = udtFenstergröße.Bottom - udtFenstergröße.Top
'Hier eventuell etwas experimentieren.
'Dient zur Anpassung, wenn das Excel-Fenster nicht maximale Größe hat
If GesamtBreite < GetSystemMetrics(SM_CXSCREEN) Then
lngFortschrittsleiste = CLng((GetSystemMetrics(SM_CXSCREEN) _
/ 1000) * 488)
Else
lngFortschrittsleiste = CLng((GetSystemMetrics(SM_CXSCREEN) _
/ 1000) * 465)
End If
If lngFortschrittsleiste > GesamtBreite Then Exit Sub
If BreiteProzent > 100 Then BreiteProzent = 100
If BreiteProzent < 0 Then BreiteProzent = 0
GesamtBreite = GesamtBreite - lngFortschrittsleiste
lngBreite = CLng((GesamtBreite / 1000) * BreiteProzent * 10)
udtFenstergröße.Left = 0
udtFenstergröße.Top = 0
udtFenstergröße.Right = lngBreite
udtFenstergröße.Bottom = lngGesamtHöhe
'*****Pinsel erzeugen*****
If hPinsel = 0 Then
hPinsel = CreateSolidBrush(lngFarbe)
End If
'*****Fenster DC ausleihen*****
lngDcFenster = GetDC(hFenster)
'*****Malen in DC*****
lngRück = FillRect(lngDcFenster, udtFenstergröße, hPinsel)
'*****DC zurückgeben*****
lngRück = ReleaseDC(hFenster, lngDcFenster)
End Sub

Sub Test()
Dim zähler%
For zähler = 1 To 100 Step 1
Call Fortschritt(zähler)
Application.Wait (Now + TimeSerial(0, 0, 1))
Next
End Sub