یه سوال در مورد TREE VIEW

[reza_optical]

سلام به شمایی که این نوشته رو میخونی اقا من می خوام تو TREE یه شاخه رو به یه رنگ وشاخه دیگرو به رنگ دیگه در بیارم چطو این رو میتونم انجام بدددددم مرسییییی از لطف شما

:بوس:

[Fagat_tanhaie]

با سلام
منم یه مشکلی با tree view دارم و اینه که میخوام نوشته ای که برای هر node بنویسم دو رنگی
باشه . یعنی نصف نوشته یه رنگ و بقیه یه رنگ دیگه .
اگه راهنمایی کنین ممنون میشم

[yavari]

سلام
خب همون جور که می دونید treeview همچین قابلیتی نداره
حالا شما بیاین از Microsoft Outline Control استفاده کنید
شاید مشکلتونو حل کنه
امیدوارم

موفق باشید

[sohrab o]

age ye sourcy bezari behtare hame motevage mishan
merc

[thief_cns]

دوستان اگر درست متوجه شده با شم می خواهید روی TREE VIEW تغیرات بدهید یک سری کد برایتان می فرستم امیدوارم به کارتان بیاید


یک ماژول باز کنید
'---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 = 0&
.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 = LongToUShort(&HFF00&)
.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

---------------------------------------------------------------------------------------------------
حال یک فرم به همراه یک TREE VIEW



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

[vbhamed]

سلام
از Addressof winproc اشکال میگیره

[coder]

مثلا برای تغییر رنگ پس زمینه
Tree.Nodes.Item("*").BackColor = vbYellow
بجای ستاره نامی رو که قبلا برای صدا کردن نود بهش اختصاص دادی ( یعنی همون key موقع اجرای دستور Add)مینویسی . برای دورنگ کردن متن راهی بنظرم نمیرسه ولی فکر نمیکنم جذابیت داشته باشه. میشه از Image مناسب برای هر نود استفاده کرد