用API怎么改变ListBox项目背景色?

laery 2009-11-03 05:21:56

...全文

309 6 打赏收藏转发到动态举报

写回复

用AI写文章

6 条回复

切换为时间正序

请发表友善的回复…

发表回复

三断笛 2009-11-03

打赏
举报

3楼，下棋不？头像都是四大名局之首了，相信肯定是高手

贝隆 2009-11-03

打赏
举报

学习

SYSSZ 2009-11-03

打赏
举报

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)

End Sub