Fortschrittsanzeige in Statusleiste mit Prozentangabe

Ein länger laufendes Makro blockiert in Excel so ziemlich alles.
Damit der User erkennt, dass sich noch was tut, kann man in der Statusleiste Text ausgeben. Wenn man die richtigen Zeichen nimmt, kann man sogar so etwas wie Laufbalken erzeugen. Professioneller dagegen sieht ein gemalter Laufbalken aus, mit einer Prozentanzeige daneben. Das Ganze ist verpackt in eine Prozedur, der folgende Parameter übergeben werden können: Breite in Prozent, Farbe des Fortschrittsbalken, Rahmenfarbe des Balkens, dann Textfarbe, Schriftart, Schriftdicke und Schriftgröße der Prozentanzeige. Es wird das Fensterhandle der Statusleiste ermittelt, der freien Platz darin wird abgeschätzt, der DC wird ausgeliehen und mit ein paar API-Funktionen wird ein gefülltes Rechteck, der Rahmen und der Prozenttext gezeichnet.

Beispieldatei (Fortschritt.zip 16 kB)

Private Declare Function DeleteObject Lib "gdi32" _
  (ByVal hObject 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 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 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 FrameRect Lib "user32" _
  (ByVal hdc As Long, lpRect As RECT, _
  ByVal hBrush 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 Const LF_FACESIZE = 32
Private Const DT_CENTER = &H1
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 RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

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

Sub test()
Dim zähler%
  For zähler = 1 To 100 Step 3
    Fortschritt _
      BreiteProzent:=zähler, _
      FarbeFortschrittsbalken:=vbGreen, _
      Textfarbe:=vbRed, _
      Schriftart:="Times New Roman", _
      Schriftdicke:=6, _
      Schriftgrösse:=15
    Application.Wait (Now + TimeSerial(0, 0, 1))
  Next
  Application.StatusBar = False
End Sub

Sub Fortschritt(ByVal BreiteProzent, _
  Optional FarbeFortschrittsbalken As Long, _
  Optional Rahmenfarbe As Long, _
  Optional Textfarbe As Long, _
  Optional Schriftart As String, _
  Optional Schriftdicke As Byte, _
  Optional Schriftgrösse As Long)
Dim hPinsel As Long, hFenster As Long
Dim lngDcFenster As Long, strKlassenname As String
Dim lngTextColorOld As Long
Dim udtSchriftart As LOGFONT
Dim udtBalkengrösse As RECT
Dim udtRahmengrösse As RECT
Dim udtRahmenText As RECT
Dim udtGesamtgrösse As RECT
Dim lngGesamtBreite As Long, lngBreite As Long
Dim lngGesamtHöhe As Long
Dim lngVerfügbareBreite As Long, lngFortschrittsleiste As Long
Dim lngFreihalten As Long, lngTextFreihalten As Long
Dim strBeschriftung As String
Dim arrFontname() As Byte
Dim lngFont As Long, lngFontOld As Long
Dim i As Long
  ReDim arrFontname(0)
  strKlassenname = "XLMAIN"
  '*****Fenster Statusleiste finden*****
  hFenster = FindWindowEx(0&, 0&, strKlassenname, Application.Caption)
  'Excel97
  'strKlassenname = "EXCEL4"
  'hFenster = FindWindowEx(hFenster, 0&, strKlassenname, vbNullString)
  'oder auf anderen Versionen (ungetestet <> XL97)
  hFenster = GetWindow(hFenster, GW_CHILD)
  '*****Größe Festlegen*****
  GetWindowRect hFenster, udtGesamtgrösse
  With udtGesamtgrösse
    lngGesamtBreite = .Right - .Left
    lngGesamtHöhe = .Bottom - .Top
  End With
  'Hier eventuell etwas experimentieren.
  lngFreihalten = GetSystemMetrics(SM_CXSCREEN) * 0.35
  lngVerfügbareBreite = lngGesamtBreite - lngFreihalten
  lngTextFreihalten = 100
  If lngVerfügbareBreite < lngTextFreihalten Then Exit Sub
  lngVerfügbareBreite = lngVerfügbareBreite - lngTextFreihalten
  If BreiteProzent > 100 Then BreiteProzent = 100
  If BreiteProzent < 0 Then BreiteProzent = 0
  lngBreite = CLng((lngVerfügbareBreite / 100) * BreiteProzent)
  With udtRahmenText
    .Left = lngVerfügbareBreite + 3
    .Top = 0
    .Right = lngVerfügbareBreite + 3 + lngTextFreihalten
    .Bottom = lngGesamtHöhe - 3
  End With
  With udtBalkengrösse
    .Left = 3
    .Top = 3
    .Right = lngBreite
    .Bottom = lngGesamtHöhe - 2
  End With
  With udtRahmengrösse
    .Left = 3
    .Top = 3
    .Right = lngVerfügbareBreite
    .Bottom = lngGesamtHöhe - 2
  End With
  With udtSchriftart
    .lfHeight = Schriftgrösse * -1
    Select Case Schriftdicke
      Case Is >= 7
        .lfWeight = FW_BOLD
      Case Is >= 5
        .lfWeight = FW_MEDIUM
      Case 4
        .lfWeight = FW_NORMAL
      Case 3
        .lfWeight = FW_LIGHT
      Case Else
        .lfWeight = FW_THIN
    End Select
    If Schriftart = "" Then 'default
      'arrFontname = StrConv("Times New Roman" & _
        Chr$(0), vbFromUnicode)
      'arrFontname = StrConv("MS Sans Serif" & _
        Chr$(0), vbFromUnicode)
    Else
      Schriftart = Left$(Schriftart, 31)
      arrFontname = StrConv(Schriftart & _
        Chr$(0), vbFromUnicode)
    End If
    For i = 0 To UBound(arrFontname)
      .lfFaceName(i) = arrFontname(i)
    Next
  End With
  Application.StatusBar = ""
  '*****Fenster DC ausleihen*****
  lngDcFenster = GetDC(hFenster)
  '*****Fortschrittsbalken Malen in DC*****
  hPinsel = CreateSolidBrush(FarbeFortschrittsbalken)
  FillRect lngDcFenster, udtBalkengrösse, hPinsel
  DeleteObject hPinsel
  '*****Rahmen Malen in DC*****
  hPinsel = CreateSolidBrush(Rahmenfarbe)
  FrameRect lngDcFenster, udtRahmengrösse, hPinsel
  DeleteObject hPinsel
  '*****Beschriftung Malen in DC*****
  strBeschriftung = Format$(BreiteProzent, "0.00") & " %"
  lngFont = CreateFontIndirect(udtSchriftart)
  lngFontOld = SelectObject(lngDcFenster, lngFont)
  lngTextColorOld = GetTextColor(lngDcFenster)
  SetTextColor lngDcFenster, Textfarbe
  DrawText lngDcFenster, strBeschriftung, _
    Len(strBeschriftung), udtRahmenText, DT_CENTER
  SetTextColor lngDcFenster, lngTextColorOld
  SelectObject lngDcFenster, lngFontOld
  DeleteObject lngFont
  '*****DC zurückgeben*****
  ReleaseDC hFenster, lngDcFenster
End Sub