关于设置Treeview背景色的问题,

[bjwanghui]

有没有哪位兄弟在VB中使用sendmessage对TreeView改变背景色?我现在遇到一个问题,如果把linestyle设为1 的时候,展开节点的时候root部位会有一个下拉的白色块,如果设为1 的时候,可以消除这种情况,但是新的问题是每一个节点如果处于该级的最后一个并且也有childnode 的时候就又出现了白色的背景块?如何解决?
我的源码是:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_STYLE = -16&
Private Const TVM_SETBKCOLOR = 4381&
Private Const TVM_GETBKCOLOR = 4383&
Private Const TVS_HASLINES = 2&

Private Sub ApplyTRVBackColor(ByVal sColor As Long)
Dim lngStyle As Long, iNode As Node
TreeView1.LineStyle = tvwTreeLines
Call SendMessage(TreeView1.hWnd, TVM_SETBKCOLOR, 0, ByVal sColor)
lngStyle = GetWindowLong(TreeView1.hWnd, GWL_STYLE)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle - TVS_HASLINES)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle)
For Each iNode In TreeView1.Nodes
iNode.BackColor = sColor
Next
End Sub
如果使用图标,请将imagelist 的backcolor也设置成sColor.
这么做的问题就有上述问题,请教高手解答.

[wangxuejun]

这个问题用简单的API是处理不了的，至少你的图标下无法添充上背景色，看看微软制作帮助文档的HTML Help Workshop，左侧目录树当设置背景色时图标也是无法上色的。
我建议你用背景图进行目录区重画，如果你必须使用这种背景色，只需要将选定的背景色去为一个IMAGE图片上图背景，再用这个IMAGE图形去刷新目录树背景就可以了，这种方法还可以用任意图形作目录树背景，效果非常棒。如果你需要我要以帖上处理代码。

[bjwanghui]

谢谢你 wangxuejun,图标区是可以上色的,就是将imagelist 的backcolor也设置成sColor,我不能处理的就是那个\每一个节点如果处于该级的最后一个并且也有childnode 的时候就又出现了白色的背景块的问题,能贴上你的处理方法吗?愿以100分相谢!

[wangxuejun]

在窗体上放置一IMAGE控件改名为Img（大小无所谓），加载一幅图片（当然可以加载一幅纯单色的图片，这就是你说的背景色了！）;再放置一个TreeView1，将以下代码复制帖入窗体代码中：


Option Explicit
Private Sub Form_Load()
Subclass Me, TreeView1
Dim Root As Node
'Add some items
With TreeView1.Nodes
Set Root = .Add(, , , "Top-level Node #1")
.Add Root.Index, tvwChild, , "Child Node #1"
.Add Root.Index, tvwChild, , "Child Node #2"
.Add Root.Index, tvwChild, , "Child Node #3"
Set Root = .Add(, , , "Top-level Node #2")
.Add Root.Index, tvwChild, , "Child Node #1"
.Add Root.Index, tvwChild, , "Child Node #2"
.Add Root.Index, tvwChild, , "Child Node #3"
Set Root = .Add(, , , "Top-level Node #3")
.Add Root.Index, tvwChild, , "Child Node #1"
.Add Root.Index, tvwChild, , "Child Node #2"
.Add Root.Index, tvwChild, , "Child Node #3"
Set Root = .Add(, , , "Top-level Node #4")
.Add Root.Index, tvwChild, , "Child Node #1"
.Add Root.Index, tvwChild, , "Child Node #2"
.Add Root.Index, tvwChild, , "Child Node #3"
End With
End Sub

Public Sub TreeViewMessage(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, RetVal As Long, UseRetVal As Boolean)
Static InProc As Boolean
Dim ps As PAINTSTRUCT
Dim TVDC As Long, drawDC1 As Long, drawDC2 As Long
Dim oldBMP1 As Long, drawBMP1 As Long
Dim oldBMP2 As Long, drawBMP2 As Long
Dim x As Long, y As Long, w As Long, h As Long
Dim TVWidth As Long, TVHeight As Long

If wMsg = WM_PAINT Then
If InProc = True Then
Exit Sub
End If
InProc = True
TVWidth = TreeView1.width \ Screen.TwipsPerPixelX
TVHeight = TreeView1.Height \ Screen.TwipsPerPixelY
w = ScaleX(Img.Picture.width, vbHimetric, vbPixels)
h = ScaleY(Img.Picture.Height, vbHimetric, vbPixels)
Call BeginPaint(hWnd, ps)
TVDC = ps.hDC
drawDC1 = CreateCompatibleDC(TVDC)
drawBMP1 = CreateCompatibleBitmap(TVDC, TVWidth, TVHeight)
oldBMP1 = SelectObject(drawDC1, drawBMP1)
drawDC2 = CreateCompatibleDC(TVDC)
drawBMP2 = CreateCompatibleBitmap(TVDC, TVWidth, TVHeight)
oldBMP2 = SelectObject(drawDC2, drawBMP2)
SendMessage hWnd, WM_PAINT, drawDC1, ByVal 0&
For y = 0 To TVHeight Step h
For x = 0 To TVWidth Step w
PaintNormalStdPic drawDC2, x, y, w, h, Img.Picture, 0, 0
Next
Next
PaintTransparentDC drawDC2, 0, 0, TVWidth, TVHeight, drawDC1, 0, 0, TranslateColor(vbWindowBackground)
BitBlt TVDC, 0, 0, TVWidth, TVHeight, drawDC2, 0, 0, vbSrcCopy
SelectObject drawDC1, oldBMP1
SelectObject drawDC2, oldBMP2
DeleteObject drawBMP1
DeleteObject drawBMP2
EndPaint hWnd, ps
RetVal = 0
UseRetVal = True
InProc = False
ElseIf wMsg = WM_ERASEBKGND Then
RetVal = 1
UseRetVal = True
ElseIf wMsg = WM_HSCROLL Or wMsg = WM_VSCROLL Or wMsg = WM_MOUSEWHEEL Then
InvalidateRect hWnd, 0, 0
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
UnSubclass TreeView1
End Sub

[wangxuejun]

Option Explicit
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type PAINTSTRUCT
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved As Byte
End Type

Declare Function BeginPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function EndPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long

Public Const WM_PAINT = &HF
Public Const WM_ERASEBKGND = &H14
Public Const WM_HSCROLL = &H114
Public Const WM_VSCROLL = &H115
Public Const WM_MOUSEWHEEL = &H20A

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSrc As Any, ByVal dwLen As Long)

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GWL_WNDPROC = (-4)
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long

Private m_hpalHalftone As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyHeight As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Public Const DI_NORMAL = &H3
Public Const DSna = &H220326
Public Const giINVALID_PICTURE As Integer = 481


Public Function TranslateColor(inCol As Long) As Long
Dim retCol As Long
OleTranslateColor inCol, 0&, retCol
TranslateColor = retCol
End Function

Public Sub PaintNormalStdPic(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, ByVal width As Long, ByVal Height As Long, ByVal picSource As Picture, ByVal xSrc As Long, ByVal ySrc As Long, Optional ByVal hPal As Long = 0)
Dim hdcTemp As Long
Dim hPalOld As Long
Dim hbmMemSrcOld As Long
Dim hdcScreen As Long
Dim hbmMemSrc As Long
If picSource Is Nothing Then GoTo PaintNormalStdPic_InvalidParam
Select Case picSource.Type
Case vbPicTypeBitmap
If hPal = 0 Then hPal = m_hpalHalftone
hdcScreen = GetDC(0&)
hdcTemp = CreateCompatibleDC(hdcScreen)
hPalOld = SelectPalette(hdcTemp, hPal, True)
RealizePalette hdcTemp
hbmMemSrcOld = SelectObject(hdcTemp, picSource.Handle)
BitBlt hdcDest, xDest, yDest, width, Height, hdcTemp, xSrc, ySrc, vbSrcCopy
SelectObject hdcTemp, hbmMemSrcOld
SelectPalette hdcTemp, hPalOld, True
RealizePalette hdcTemp
DeleteDC hdcTemp
ReleaseDC 0&, hdcScreen
Case vbPicTypeIcon
DrawIconEx hdcDest, xDest, yDest, picSource.Handle, 0, 0, 0&, 0&, DI_NORMAL
Case Else
GoTo PaintNormalStdPic_InvalidParam
End Select
Exit Sub
PaintNormalStdPic_InvalidParam:
Err.Raise giINVALID_PICTURE
End Sub

[wangxuejun]

Public Sub PaintTransparentDC(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, ByVal width As Long, ByVal Height As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal clrMask As OLE_COLOR, Optional ByVal hPal As Long = 0)
Dim hdcMask As Long
Dim hdcColor As Long
Dim hbmMask As Long
Dim hbmColor As Long
Dim hbmColorOld As Long
Dim hbmMaskOld As Long
Dim hPalOld As Long
Dim hdcScreen As Long
Dim hdcScnBuffer As Long
Dim hbmScnBuffer As Long
Dim hbmScnBufferOld As Long
Dim hPalBufferOld As Long
Dim lMaskColor As Long

hdcScreen = GetDC(0&)
If hPal = 0 Then
hPal = m_hpalHalftone
End If
OleTranslateColor clrMask, hPal, lMaskColor
hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, width, Height)
hdcScnBuffer = CreateCompatibleDC(hdcScreen)
hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
hPalBufferOld = SelectPalette(hdcScnBuffer, hPal, True)
RealizePalette hdcScnBuffer
BitBlt hdcScnBuffer, 0, 0, width, Height, hdcDest, xDest, yDest, vbSrcCopy
hbmColor = CreateCompatibleBitmap(hdcScreen, width, Height)
hbmMask = CreateBitmap(width, Height, 1, 1, ByVal 0&)
hdcColor = CreateCompatibleDC(hdcScreen)
hbmColorOld = SelectObject(hdcColor, hbmColor)
hPalOld = SelectPalette(hdcColor, hPal, True)
RealizePalette hdcColor
SetBkColor hdcColor, GetBkColor(hdcSrc)
SetTextColor hdcColor, GetTextColor(hdcSrc)
BitBlt hdcColor, 0, 0, width, Height, hdcSrc, xSrc, ySrc, vbSrcCopy
hdcMask = CreateCompatibleDC(hdcScreen)
hbmMaskOld = SelectObject(hdcMask, hbmMask)
SetBkColor hdcColor, lMaskColor
SetTextColor hdcColor, vbWhite
BitBlt hdcMask, 0, 0, width, Height, hdcColor, 0, 0, vbSrcCopy
SetTextColor hdcColor, vbBlack
SetBkColor hdcColor, vbWhite
BitBlt hdcColor, 0, 0, width, Height, hdcMask, 0, 0, DSna
BitBlt hdcScnBuffer, 0, 0, width, Height, hdcMask, 0, 0, vbSrcAnd
BitBlt hdcScnBuffer, 0, 0, width, Height, hdcColor, 0, 0, vbSrcPaint
BitBlt hdcDest, xDest, yDest, width, Height, hdcScnBuffer, 0, 0, vbSrcCopy
DeleteObject SelectObject(hdcColor, hbmColorOld)
SelectPalette hdcColor, hPalOld, True
RealizePalette hdcColor
DeleteDC hdcColor
DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
SelectPalette hdcScnBuffer, hPalBufferOld, True
RealizePalette hdcScnBuffer
DeleteDC hdcScnBuffer
DeleteObject SelectObject(hdcMask, hbmMaskOld)
DeleteDC hdcMask
ReleaseDC 0&, hdcScreen
End Sub

Public Sub PaintTransparentStdPic(ByVal hdcDest As Long, _
ByVal xDest As Long, _
ByVal yDest As Long, _
ByVal width As Long, _
ByVal Height As Long, _
ByVal picSource As Picture, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal clrMask As OLE_COLOR, _
Optional ByVal hPal As Long = 0)

Dim hdcSrc As Long
Dim hbmMemSrcOld As Long
Dim hbmMemSrc As Long
Dim udtRect As RECT
Dim hbrMask As Long
Dim lMaskColor As Long
Dim hdcScreen As Long
Dim hPalOld As Long
If picSource Is Nothing Then GoTo PaintTransparentStdPic_InvalidParam

Select Case picSource.Type
Case vbPicTypeBitmap
hdcScreen = GetDC(0&)
If hPal = 0 Then hPal = m_hpalHalftone
hdcSrc = CreateCompatibleDC(hdcScreen)
hbmMemSrcOld = SelectObject(hdcSrc, picSource.Handle)
hPalOld = SelectPalette(hdcSrc, hPal, True)
RealizePalette hdcSrc
PaintTransparentDC hdcDest, xDest, yDest, width, Height, hdcSrc, xSrc, ySrc, clrMask, hPal
SelectObject hdcSrc, hbmMemSrcOld
SelectPalette hdcSrc, hPalOld, True
RealizePalette hdcSrc
DeleteDC hdcSrc
ReleaseDC 0&, hdcScreen
Case vbPicTypeIcon
hdcScreen = GetDC(0&)
If hPal = 0 Then hPal = m_hpalHalftone
hdcSrc = CreateCompatibleDC(hdcScreen)
hbmMemSrc = CreateCompatibleBitmap(hdcScreen, width, Height)
hbmMemSrcOld = SelectObject(hdcSrc, hbmMemSrc)
hPalOld = SelectPalette(hdcSrc, hPal, True)
RealizePalette hdcSrc
udtRect.Bottom = Height
udtRect.Right = width
OleTranslateColor clrMask, 0&, lMaskColor
hbrMask = CreateSolidBrush(lMaskColor)
FillRect hdcSrc, udtRect, hbrMask
DeleteObject hbrMask
DrawIconEx hdcSrc, 0, 0, picSource.Handle, 0, 0, 0, 0, DI_NORMAL
PaintTransparentDC hdcDest, xDest, yDest, width, Height, hdcSrc, 0, 0, lMaskColor, hPal
DeleteObject SelectObject(hdcSrc, hbmMemSrcOld)
SelectPalette hdcSrc, hPalOld, True
RealizePalette hdcSrc
DeleteDC hdcSrc
ReleaseDC 0&, hdcScreen
Case Else
GoTo PaintTransparentStdPic_InvalidParam
End Select
Exit Sub
PaintTransparentStdPic_InvalidParam:
End Sub

Public Sub Subclass(frm As Form, tv As TreeView)
Dim lProc As Long
If GetProp(tv.hWnd, "VBTWndProc") <> 0 Then Exit Sub
lProc = GetWindowLong(tv.hWnd, GWL_WNDPROC)
SetProp tv.hWnd, "VBTWndProc", lProc
SetProp tv.hWnd, "VBTWndPtr", ObjPtr(frm)
SetWindowLong tv.hWnd, GWL_WNDPROC, AddressOf WndProcTV
End Sub

Public Sub UnSubclass(tv As TreeView)
Dim lProc As Long
lProc = GetProp(tv.hWnd, "VBTWndProc")
If lProc = 0 Then Exit Sub
SetWindowLong tv.hWnd, GWL_WNDPROC, lProc
RemoveProp tv.hWnd, "VBTWndProc"
RemoveProp tv.hWnd, "VBTWndPtr"
End Sub

Public Function WndProcTV(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim lProc As Long
Dim lPtr As Long
Dim tmpForm As Form
Dim bUseRetVal As Boolean
Dim lRetVal As Long

bUseRetVal = False
lProc = GetProp(hWnd, "VBTWndProc")
lPtr = GetProp(hWnd, "VBTWndPtr")
CopyMemory tmpForm, lPtr, 4
tmpForm.TreeViewMessage hWnd, wMsg, wParam, lParam, lRetVal, bUseRetVal
CopyMemory tmpForm, 0&, 4
If bUseRetVal = True Then
WndProcTV = lRetVal
Else
WndProcTV = CallWindowProc(lProc, hWnd, wMsg, wParam, lParam)
End If
End Function

'这帖和上帖都放入一个模块Module1中，然后运行看看效果吧！

[bjwanghui]

wangxuejun,谢谢你，我试了一下，为什么在nodeclick的时候图片会出现一块一块的，我用了refresh 的方法有所改变但是不理想。你遇到过这样的问题吗？20分给你太少了，这样吧，你到http://community.csdn.net/Expert/topic/3630/3630987.xml?temp=.8065607这里我再给你70分。

[bjwanghui]

wangxuejun，谢谢你，我试了，在expand和nodeclick事件中加入了treeview1.refresh就解决了，你到http://community.csdn.net/Expert/topic/3630/3630987.xml?temp=.8065607再手70分吧。

[xiaoMONKEY]

顶