(Resolved)TreeView with Gradient background

[planethax]

I found a code to have a TreeView with Gradient background.
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?

I had this question with my other post but decided to separate it.

I will also upload the sample I downloaded
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]

I guess this is not as easy of a repair as I thought it would be.
I have emailed the author of the code but am still waiting a reply.
If some one would download and compile the project and tell us their outcome that would be great.
I originally got the code from
http://www.freevbcode.com/ShowCode.asp?ID=2135
Thanx, Planethax

[planethax]

Well no reply yet from the author, and no replies here, Has ne one tried this code?
Would be nice to know whether its my machines or the code?

[dglienna]

I'll byte

I'll let you know in 10 or maybe longer minutes.

Well, it runs fine in the IDE, but crashes as an .exe
I added a few error traps, but it still crashes.
I've sent an error report once. Next, I'll look at the info.

Running XP Home on my laptop 512MB ram.

[MartinLiss]

planethax, you asked this same question before. Please don't do that.

[dglienna]

Fixed it. I exited Function that had Crash2 as the error trap.
I don't know what it was, but it doesn't crash any more.

Neat code, too. I noticed he has other gradient fills. I might check them out.

[planethax]

Thanx dglienna.
Your the best!!!!!
I am now going to compare the two to see axactly what you did,
Hey I may learn something? Prolly not though lol.
Thanx again.

[dglienna]

I would put a msgbox in each section of the select case near crash2 in the module. I noticed that it loops through there about 5 times. I would guess that one of them fails. If you find out, we may be able to pinpoint the cause. Right now it just exits the function on the error.