Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 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 As String * 50
End Type
Const LB_GETITEMRECT = 408
Private Sub Form_Load()
Dim intX As Integer
For intX = 0 To 50
Lstdisp.AddItem Format(CStr(intX), "00") & "这是一个试验"
Next
'API函数中都以像素为单位的
Me.ScaleMode = vbPixels
End Sub
'判断一个Ansi字符串的长度
'一个中文字符长度为2，一个英文字符长度为1
Private Function GetTextLengthA(ByVal strText) As Long
Dim intX As Integer
Dim lngTextLength As Long
lngTextLength = Len(strText) '返回Unicode的长度
For intX = 1 To lngTextLength
'Asc()：英文字符返回值大于零，中文字符返回值小于零
If Asc(Mid$(strText, intX, 1)) < 0 Then lngTextLength = lngTextLength + 1
Next
GetTextLengthA = lngTextLength
End Function
Private Sub lstDisp_Click()
Dim pRec As RECT
Dim pRgn As Long
Dim pFont As Long
Dim pBrush As Long
Dim pDC As Long
Dim lpLogFont As LOGFONT
'得到列表框当前选中项目的矩形位置
SendMessage Lstdisp.hwnd, LB_GETITEMRECT, Lstdisp.ListIndex, pRec
'根据得到的矩形位置创建一个区域
pRgn = CreateRectRgn(pRec.Left, pRec.Top, pRec.Right, pRec.Bottom)
'创建一个样式为Solid的刷子
pBrush = CreateSolidBrush(picBackColor.BackColor)
'得到列表框的Device Context
pDC = GetDC(Lstdisp.hwnd)
'创建一个字体，并根据当前列表框中字体大小进行设置
With lpLogFont
.lfHeight = TextHeight(Lstdisp.Text)
.lfFaceName = "宋体" & Chr(0)
End With
pFont = CreateFontIndirect(lpLogFont)
'将创建的字体选入设备上下文
pFont = SelectObject(pDC, pFont)
'用刷子对区域进行填充
FillRgn pDC, pRgn, pBrush
'设置输出文字的颜色和底色
SetTextColor pDC, picTextColor.BackColor
SetBkColor pDC, picBackColor.BackColor
'输出文字
TextOut pDC, pRec.Left, pRec.Top, ByVal Lstdisp.Text, GetTextLengthA(Lstdisp.Text)
'选回原来的字体
pFont = SelectObject(pDC, pFont)
'一些必要的清理工作
DeleteObject pRgn
DeleteObject pBrush
DeleteObject pFont
ReleaseDC Lstdisp.hwnd, pDC
End Sub
评论0