Andere Schriftarten in der Statusbar

Die Schriftart der Statusbar von XL97 kann standardmäßig nicht verändert werden. Man kann aber einen Text in das Fenster malen, der beliebig formatiert werden kann. Es wird die gleiche Technik wie unter 10 (Fortschrittsleiste) verwendet.

Beispieldatei (statusbar.zip 22 KB)

Option Explicit
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 GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) 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 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 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 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

Private Sub testen()
Dim zähler%
For zähler = 1 To 10
    Statustext "Test : " & zähler, _
    Textfarbe:=vbRed, _
    Schriftdicke:=3, _
    Schriftgrösse:=12, _
    Ausrichtung:=2, _
    Kursiv:=True, _
    Schriftart:="", _
    Durchgestrichen:=False, _
    Unterstrichen:=True
    Application.Wait (Now + TimeSerial(0, 0, 1))
Next
Application.StatusBar = False
End Sub 

Public Sub Statustext(Text As String, _
Optional Textfarbe As Long, _
Optional Schriftart As String, _
Optional Schriftdicke As Byte, _
Optional Schriftgrösse As Long, _
Optional Ausrichtung As Byte, _
Optional Kursiv As Boolean, _
Optional Durchgestrichen As Boolean, _
Optional Unterstrichen As Boolean)
Dim hFenster As Long
Dim lngDcFenster As Long, strKlassenname As String
Dim lngTextColorOld As Long
Dim udtSchriftart As LOGFONT
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 AusrichtungText As Long
Dim i As Long
  ReDim arrFontname(0)
  'Ausrichtung Text, default links
  AusrichtungText = DT_LEFT
  If Ausrichtung = 2 Then AusrichtungText = DT_CENTER
  If Ausrichtung = 3 Then AusrichtungText = DT_RIGHT
  'Fenster Excel finden
  strKlassenname = "XLMAIN"
  hFenster = FindWindowEx(0&, 0&, strKlassenname, Application.Caption)
  'Fenster Statusleiste finden

  'Unter Excel97 folgende zwei Zeilen
  'strKlassenname = "EXCEL4"
  'hFenster = FindWindowEx(hFenster, 0&, strKlassenname, vbNullString)

  'oder auf anderen Versionen (ungetestet <> XL97)
  hFenster = GetWindow(hFenster, GW_CHILD)
  'Größe Statusleiste Ermitteln
  GetWindowRect hFenster, udtGesamtgrösse
  With udtGesamtgrösse
     lngGesamtBreite = .Right - .Left
     lngGesamtHöhe = .Bottom - .Top
  End With
  'Hier eventuell etwas experimentieren.
  'Platz am rechten Rand freihalten
  lngFreihalten = GetSystemMetrics(SM_CXSCREEN) * 0.35
  'Das bleibt übrig zum beschriften
  lngTextFreihalten = lngGesamtBreite - lngFreihalten
  With udtRahmenText
     .Left = 10
     .Top = 0
     .Right = lngTextFreihalten
     .Bottom = lngGesamtHöhe - 3
  End With
  With udtSchriftart
    .lfItalic = Kursiv
    .lfStrikeOut = Durchgestrichen
    .lfUnderline = Unterstrichen
    .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)
  strBeschriftung = Text
  'Font erzeugen
  lngFont = CreateFontIndirect(udtSchriftart)
  'Alte Font sichern, neue Font setzen
  lngFontOld = SelectObject(lngDcFenster, lngFont)
  'Alte Farbe sichern
  lngTextColorOld = GetTextColor(lngDcFenster)
  'neue Farbe setzen
  SetTextColor lngDcFenster, Textfarbe
  'Text malen
  DrawText lngDcFenster, strBeschriftung, _
  Len(strBeschriftung), udtRahmenText, AusrichtungText
  If Not EinstellungenLassen Then
     'Alte Farbe setzen
     SetTextColor lngDcFenster, lngTextColorOld
     'Alte Font setzen
     SelectObject lngDcFenster, lngFontOld
     'Erzeugte Font löschen
     DeleteObject lngFont
  End If
  'DC zurückgeben
  ReleaseDC hFenster, lngDcFenster
End Sub