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?
Printable View
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?
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.
This should work. Place the following code in a module:
VB Code:
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:
VB Code:
SetTVBackColor TreeView1, vbRed ' substitute vbRed for whatever color you want
perfect, ty very muchBruce, worked great,
I also found a module to make the background into a gradient which is pretty neat as well.
You should post it here.
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
VB 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
VB 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
Ok found where I got the code, but its not much help, it was from
http://www.freevbcode.com/ShowCode.Asp?ID=2135
I have uploaded the sample that I downloaded from the site.
Maybe easier for you to see where the problem lies.