[Resolved]treeview background color or image

[planethax]

I can not seem to find how to change a treeview background from the white to a different color or even image?
Is this possible?

[MartinLiss]

If you Google treeview background you'll find a bunch of links on the topic. However I think the problem is that you can do those things with the VB5 control but not the VB6 one. Don't let me stop you from investigating however.

[BruceG]

This should work. Place the following code in a module:

Option Explicit
 
Private Const GWL_STYLE                  As Long = (-16)
Private Const TVS_HASLINES               As Long = 2
Private Const TV_FIRST                   As Long = &H1100
Private Const TVM_SETBKCOLOR             As Long = (TV_FIRST + 29)
 
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 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
 
'-----------------------------------------------------------------------------
Public Sub SetTVBackColor(pobjTV As TreeView, plngBackColor As Long)
'-----------------------------------------------------------------------------
 
    Dim lngTVHwnd   As Long
    Dim lngStyle    As Long
    Dim objTVNode   As Node
    
    lngTVHwnd = pobjTV.hwnd
    
    ' Change the background
    Call SendMessage(lngTVHwnd, TVM_SETBKCOLOR, 0, ByVal plngBackColor)
    
    ' Set the backcolor of the nodes ...
    For Each objTVNode In pobjTV.Nodes
        objTVNode.BackColor = plngBackColor
    Next
 
    ' Reset the treeview style so the tree lines appear properly ...
    lngStyle = GetWindowLong(lngTVHwnd, GWL_STYLE)
    
    ' If the treeview has lines, temporarily remove them so the back
    ' repaints to the selected colour, then restore ...
    If lngStyle And TVS_HASLINES Then
       Call SetWindowLong(lngTVHwnd, GWL_STYLE, lngStyle Xor TVS_HASLINES)
       Call SetWindowLong(lngTVHwnd, GWL_STYLE, lngStyle)
    End If
    
End Sub

Usage would be:

SetTVBackColor TreeView1, vbRed  ' substitute vbRed for whatever color you want

[planethax]

perfect, ty very muchBruce, worked great,
I also found a module to make the background into a gradient which is pretty neat as well.

[dglienna]

You should post it here.

[planethax]

OK, thing is, I lost the page in history where I found the code
Now I have a problem with it,
When I run my project within vb it works great, as soon as I compile it into an .exe windows has an error and shuts down, doesnt tell me what error is though.
Any ways, the code consists of a module then a call to the module, I will post here and maybe one of you experts can find the reason of the error?


MODULE CODE

'---Bas module code---
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type PAINTSTRUCT
    hDC As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved As Byte
End Type
Private Declare Function BeginPaint Lib "user32" _
    (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" _
    (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
 
Private Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type
    
Private Type GRADIENT_TRIANGLE
    Vertex1 As Long
    Vertex2 As Long
    Vertex3 As Long
End Type
 
Const GRADIENT_FILL_TRIANGLE As Long = &H2
 
Private Declare Function GradientFillTri Lib "msimg32" Alias "GradientFill" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_TRIANGLE, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC& Lib "user32" (ByVal hWnd As Long)
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef 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 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 ValidateRectBynum& Lib "user32" Alias "ValidateRect" (ByVal hWnd As Long, ByVal lpRect As Long)
Declare Function ReleaseDC& Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long)
 
Private Const GWL_WNDPROC = (-4)
Private Const WM_PAINT = &HF
Private Const WM_ERASEBKGND = &H14
Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_SETREDRAW = &HB
Dim vert(3) As TRIVERTEX
Dim gTri(1) As GRADIENT_TRIANGLE
Dim OldProc As Long, bPainting As Boolean
Dim TVWidth As Long, TVHeight As Long
 
Public Sub SubClass(obj As Object)
   Dim h As Long
   On Error Resume Next
   h = obj.hWnd
   If Err Or (OldProc <> 0) Then Exit Sub
   PrepareVertex obj
   OldProc = SetWindowLong(h, GWL_WNDPROC, AddressOf WndProc)
End Sub
 
Public Sub UnSubClass(obj As Object)
   Dim h As Long
   On Error Resume Next
   h = obj.hWnd
   If Err Or (OldProc = 0) Then Exit Sub
   SetWindowLong h, GWL_WNDPROC, OldProc
   OldProc = 0
End Sub
 
Public Function WndProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Dim TVDC As Long, TempDC As Long
   Dim oldBMP As Long, TempBMP As Long
   Dim ps As PAINTSTRUCT
   Select Case wMsg
          Case WM_PAINT
               If bPainting = False Then
                     BeginPaint hWnd, ps
                     bPainting = True
                     TVDC = GetDC(hWnd)
                     TempDC = CreateCompatibleDC(TVDC)
                     TempBMP = CreateCompatibleBitmap(TVDC, TVWidth, TVHeight)
                     oldBMP = SelectObject(TempDC, TempBMP)
                     SendMessage hWnd, WM_PAINT, TempDC, ByVal 0&
                     GradientFillTri TVDC, vert(0), 4, gTri(0), 2, GRADIENT_FILL_TRIANGLE
                     TransparentBlt TVDC, 0, 0, TVWidth, TVHeight, TempDC, 0, 0, TVWidth, TVHeight, TranslateColor(vbWindowBackground)
                     SelectObject TempDC, oldBMP
                     DeleteObject TempBMP
                     ReleaseDC hWnd, TempDC
                     ReleaseDC hWnd, TVDC
                     WndProc = 0
                     bPainting = False
                     EndPaint hWnd, ps
                     Exit Function
               End If
           Case WM_ERASEBKGND
                WndProc = 1
                Exit Function
           Case WM_HSCROLL, WM_VSCROLL, WM_MOUSEWHEEL
                InvalidateRect hWnd, 0, False
           Case Else
   End Select
   WndProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
End Function
 
Private Sub PrepareVertex(tv As Object)
'!!!Play with colors!!!
TVWidth = tv.Width \ Screen.TwipsPerPixelX
TVHeight = tv.Height \ Screen.TwipsPerPixelY
 
With vert(0)
    .x = 0
    .y = 0
    .Red = 0&
    .Green = LongToUShort(&HFF00&) '0
    .Blue = LongToUShort(&HFF00&)
    .Alpha = 0&
End With
With vert(1)
    .x = TVWidth
    .y = 0
    .Red = 0 'LongToUShort(&HFF00&)
    .Green = 0&
    .Blue = LongToUShort(&HFF00&)
    .Alpha = 0&
End With
With vert(2)
    .x = TVWidth
'    .x = Me.ScaleWidth
    .y = TVHeight
    .Red = 0
    .Green = 0&
    .Blue = 0 'LongToUShort(&HFF00&)
    .Alpha = 0&
End With
With vert(3)
    .x = 0
    .y = TVHeight
    .Red = 0 'LongToUShort(&HFF00&)
    .Green = LongToUShort(&HFF00&)
    .Blue = LongToUShort(&HFF00&)
    .Alpha = 0&
End With
gTri(0).Vertex1 = 0
gTri(0).Vertex2 = 1
gTri(0).Vertex3 = 2
 
gTri(1).Vertex1 = 0
gTri(1).Vertex2 = 2
gTri(1).Vertex3 = 3
End Sub
 
Private Function LongToUShort(ULong As Long) As Integer
   LongToUShort = CInt(ULong - &H10000)
End Function
 
Private Function TranslateColor(inCol As Long) As Long
   Dim retCol As Long
   OleTranslateColor inCol, 0&, retCol
   TranslateColor = retCol
End Function

FORM CODE

Private Sub Form_Load()
Dim Root As Node
 
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"
Root.Expanded = True
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"
Root.Expanded = True
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"
Root.Expanded = True
End With
 
SubClass TreeView1
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
  UnSubClass TreeView1
End Sub

[planethax]

Ok found where I got the code, but its not much help, it was from
http://www.freevbcode.com/ShowCode.Asp?ID=2135

[planethax]

I have uploaded the sample that I downloaded from the site.
Maybe easier for you to see where the problem lies.

[DM03]

This should work. Place the following code in a module:

HI everyone
This is the 1st time I'm using treeviews and I tried your code but it didn't work..
I have a type mismatch error ('13') at line 1 in the form..
I would love to get some help. Thank you very much!!