设定StatusBar的文字成不同的颜色
设定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
补充：软件开发 , Vb ,上一个：实现画面的各种切换方法
下一个：闪烁的标题栏
- 更多VB疑问解答：
- 批处理转移文 之errorlevel
- vb 6.0 调用vb.net dll混合程序集错误
- VB inet控件访问ftp 本机测试通过客户机inet控件使用失败。急！！
- 求助在Dir1控件当前目录下新建一个文件夹的代码
- CreateObject创建Word Excel对象失败，提示，无法加载DLL，怎么解决？
- 有两个磁盘阵列,如何使用能达到最好的效果
- cloudStack 如何实现 vSphere的DRS功能
- 和难缠客户的那些事儿
- 批处理转移文 之errorlevel
- vb 6.0 调用vb.net dll混合程序集错误
- VB inet控件访问ftp 本机测试通过客户机inet控件使用失败。急！！
- 求助在Dir1控件当前目录下新建一个文件夹的代码
- CreateObject创建Word Excel对象失败，提示，无法加载DLL，怎么解决？
- 有两个磁盘阵列,如何使用能达到最好的效果
- cloudStack 如何实现 vSphere的DRS功能
