设定StatusBar的文字成不同的颜色

原始来源: cww

设定StatusBar上的文字，该文字以StatusBar所在Form的字型设定为准，并以form
的ForeColor为字的颜色，文字过长时，自动会截除
这个程式的实质意义不太大，因为当文字被盖掉後需自行重新再呼叫这个Sub才能再
将文字显示出来，除非我们再使用Subclassing的方式，於statusBar接收到WM_PAINT
时，去呼叫这个SubRoutine，这程式着重於Font的了解

'below is within Form
Private Sub Command1_Click()
Call ShowPanelText(StatusBar1, 1, "这是一个有趣的程式hahahaha")
End Sub

'第一个叁数传入StatusBar
'第二个叁数表示文字要在第几个panel上 显示，由1算起
'第三个叁数是待显示的字串
Private Sub ShowPanelText(StatusBar1 As StatusBar, Pno As Long, ByVal PanelText
As String)
Dim bkcolor As Long
 Dim Color As Long
 Dim res As Long
 Dim aRect As RECT, rect5 As RECT
 Dim hfont As Long
 Dim hdc2 As Long
 Dim TextHeight As Long
 Dim tx As TEXTMETRIC
 Dim oScaleT As Long, oScaleL As Long, oScaleH As Long, oScaleW As Long
 Dim oScaleM As Long

 oScaleM = Me.ScaleMode
 oScaleT = Me.ScaleTop
 oScaleL = Me.ScaleLeft
 oScaleH = Me.ScaleHeight
 oScaleW = Me.ScaleWidth
 Me.ScaleMode = 3

 hdc2 = GetDC(StatusBar1.hwnd)
 Call GetTextMetrics(Me.hdc, tx) '取得form 字型资讯
 hfont = CreateFont(tx.tmHeight, tx.tmAveCharWidth, 0, 0, _
         tx.tmWeight, 0, 0, 0, tx.tmCharSet, 0, 0, 0, _
         tx.tmPitchAndFamily, Me.Font.Name) '依form的字型产生另一个font
 '因为不知如何取得font的handle只好，使用CreateFont的方式来取得 hfont
 Call SelectObject(hdc2, hfont) '设字型
 res = SetTextColor(hdc2, Me.ForeColor) '设字的颜色
 bkcolor = GetSysColor(COLOR_BTNFACE)
 SetBkColor hdc2, bkcolor '设字的背景色
 SetTextAlign hdc2, TA_TOP
 TextHeight = Me.TextHeight(PanelText)
 aRect.Top = (StatusBar1.Height - TextHeight) \ 2
 If StatusBar1.Style = 0 Then
    aRect.Left = StatusBar1.Panels(Pno).Left + 2
    aRect.Right = aRect.Left + StatusBar1.Panels(Pno).Width - 6
 Else
    aRect.Left = StatusBar1.Left + 2
    aRect.Right = StatusBar1.Width - 6
 End If
 aRect.Bottom = StatusBar1.Height
 InvalidateRect StatusBar1.hwnd, aRect, 1 '宣告工作区无效，用来重画statusBar
 UpdateWindow StatusBar1.hwnd
 DrawText hdc2, PanelText, LenB(StrConv(PanelText, vbFromUnicode)), aRect, 0
 ReleaseDC StatusBar1.hwnd, hdc2
 DeleteObject (hfont)
 Me.ScaleMode = oScaleM
 Me.ScaleHeight = oScaleH
 Me.ScaleTop = oScaleT
 Me.ScaleLeft = oScaleL
 Me.ScaleWidth = oScaleW
End Sub

'below is within .bas module
Option Explicit
Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
        (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
         ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, _
         ByVal C As Long, ByVal OP As Long, ByVal CP As Long, _
         ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
        (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, _
        ByVal crColor As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
        ByVal hdc As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
        ByVal crColor As Long) As Long
Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, _
        ByVal wFlags As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
        ByVal hObject As Long) As Long
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
Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, _
        lpRect As RECT, ByVal bErase As Long) As Long

Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Const COLOR_BTNFACE = 15
Public Const TA_TOP = 0