VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - 设定StatusBar的文字成不同的颜色
发表评论(0)作者:, 平台:, 阅读:11537, 日期:2000-03-29


设定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