A vfp treeview with background image

Published on by Yousfi Benameur

Visual foxpro cannot make an image background to a treeview.this is an artifact to do that.
forms are used (top level,alwaysOnTop=.t.) one embed the treeview and makes the transparency.
the second embed the image.with bindevent can glue the 2 forms to make the user shows only one.
all is not perfect , there is some flickers.
Its a style exercice to manipulate object and its a good lesson for the world foxers.

Its the same method i used in an article before for grid background.

-Can- set the treeview backcolor

        - set the background image

         -Fontname,fontsize ,bold,italic,underline

         -Expand nodes or collapse them

        -Set the background alpha color and switch btween color/image

*code revisited and corrected because the provider rich text editor dont right (cut some endlines and coma....)

note: any one point to me that typo.

-sunday 28 february 2016-

Click on code to select [then copy] -click outside to deselect


*save this code as ymaster.prg
*I disabled the backcolor treeview button (can see the code and test).its a bug in MS treeview version 6).

*Begin code ymaster.prg
Publi ymaster As Form , yslave As Form
ymaster=Newobject("ymast")
ymaster.Show
Read Events
Retu
*

Define Class ymast As Form
    BorderStyle = 3
	Height = 593
	Width = 410
	ShowWindow = 2
	ShowTips = .T.
	AutoCenter = .T.
	Caption = "Treeview"
   Icon = home(4)+"icons\industry\sinewave.ico"
	AlwaysOnTop = .T.
	lexpanded = .F.
	Name = "ymaster"

	Add Object oleimageslist As OleControl With ;
		oleclass="MSComctlLib.ImageListCtrl.2",;
		Top = 0, ;
		Left = 372, ;
		Height = 100, ;
		Width = 100, ;
		Name = "oleImagesList"

	Add Object oletreeview As OleControl With ;
		oleclass="MSComctlLib.TreeCtrl.2",;
		Top = 0, ;
		Left = 0, ;
		Height = 445, ;
		Width = 413, ;
		Anchor = 15, ;
		Name = "oleTreeview"

	Add Object text1 As TextBox With ;
		Anchor = 240, ;
		Height = 25, ;
		Left = 81, ;
		Top = 475, ;
		Width = 314, ;
		Name = "Text1"

	Add Object cmdgetdir As CommandButton With ;
		Top = 475, ;
		Left = 4, ;
		Height = 25, ;
		Width = 72, ;
		Anchor = 240, ;
		Caption = "\<Directory...", ;
		Name = "cmdGetDir"

	Add Object cmdch As CommandButton With ;
		Top = 506, ;
		Left = -1, ;
		Height = 25, ;
		Width = 85, ;
		Anchor = 240, ;
		Caption = "\<Change icon...", ;
		Name = "cmdCh"

	Add Object command3 As CommandButton With ;
		Top = 503, ;
		Left = 291, ;
		Height = 25, ;
		Width = 110, ;
		Anchor = 240, ;
		Caption = "Expand All Nodes", ;
		Name = "Command3"


	Add Object command1 As CommandButton With ;
		Top = 503, ;
		Left = 85, ;
		Height = 25, ;
		Width = 132, ;
		Anchor = 240, ;
		Caption = "Treeview BackColor...", ;
		Enabled = .F., ;
		ToolTipText = "Bug with API painting", ;
		Name = "Command1"

	Add Object command2 As CommandButton With ;
		Top = 552, ;
		Left = 84, ;
		Height = 27, ;
		Width = 132, ;
		Caption = "Treeview forecolor1...", ;
		ToolTipText = "Forecolor method1", ;
		Name = "Command2"

	Add Object command4 As CommandButton With ;
		Top = 557, ;
		Left = 85, ;
		Height = 27, ;
		Width = 132, ;
		Anchor = 240, ;
		Caption = "Treeview forecolor2...", ;
		ToolTipText = "Forecolor method2", ;
		Name = "Command4"

	Add Object command5 As CommandButton With ;
		Top = 532, ;
		Left = 294, ;
		Height = 27, ;
		Width = 84, ;
		Anchor = 240, ;
		Caption = "Font object", ;
		Visible = .T., ;
		Name = "Command5"

	Add Object check1 As Checkbox With ;
		Top = 507, ;
		Left = 222, ;
		Height = 24, ;
		Width = 60, ;
		Anchor = 240, ;
		Alignment = 0, ;
		Caption = "Bold", ;
		Style = 1, ;
		Visible = .T., ;
		Name = "Check1"

	Add Object check2 As Checkbox With ;
		Top = 530, ;
		Left = 223, ;
		Height = 24, ;
		Width = 60, ;
		Anchor = 240, ;
		Alignment = 0, ;
		Caption = "Italic", ;
		Style = 1, ;
		Visible = .T., ;
		Name = "Check2"

	Add Object check3 As Checkbox With ;
		Top = 556, ;
		Left = 225, ;
		Height = 24, ;
		Width = 60, ;
		Anchor = 240, ;
		Alignment = 0, ;
		Caption = "Underline", ;
		Style = 1, ;
		Visible = .T., ;
		Name = "Check3"

	Add Object command6 As CommandButton With ;
		Top = 563, ;
		Left = 297, ;
		Height = 25, ;
		Width = 110, ;
		FontBold = .T., ;
		FontSize = 8, ;
		Anchor = 240, ;
		Caption = "yAlpha_Backcolor", ;
		ToolTipText = "Alpha backcolor ", ;
		ForeColor = Rgb(255,0,0), ;
		BackColor = Rgb(0,255,0), ;
		Name = "Command6"

	Add Object command7 As CommandButton With ;
		Top = 560, ;
		Left = 1, ;
		Height = 27, ;
		Width = 84, ;
		FontBold = .T., ;
		FontSize = 8, ;
		Anchor = 240, ;
		Caption = "yAlpha_Image...", ;
		ForeColor = Rgb(255,0,0), ;
		BackColor = Rgb(0,255,0), ;
		Name = "Command7"

	Add Object optiongroup1 As OptionGroup With ;
		AutoSize = .T., ;
		ButtonCount = 1, ;
		Anchor = 240, ;
		BackStyle = 0, ;
		BorderStyle = 0, ;
		Value = 1, ;
		Height = 27, ;
		Left = 27, ;
		Top = 532, ;
		Width = 28, ;
		Name = "Optiongroup1", ;
		Option1.BackStyle = 0, ;
		Option1.Caption = "", ;
		Option1.Value = 1, ;
		Option1.Height = 17, ;
		Option1.Left = 5, ;
		Option1.MousePointer = 15, ;
		Option1.ToolTipText = "image or backcolor", ;
		Option1.Top = 5, ;
		Option1.Width = 18, ;
		Option1.AutoSize = .T., ;
		Option1.Name = "Option1"

	Add Object label1 As Label With ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 18, ;
		Anchor = 240, ;
		BackStyle = 0, ;
		Caption = "?", ;
		Height = 32, ;
		Left = 380, ;
		MousePointer = 15, ;
		Top = 531, ;
		Width = 17, ;
		ForeColor = Rgb(0,255,0), ;
		ToolTipText = "Summary help", ;
		Name = "Label1"

	Procedure filltree
		Parameters m.path, m.nlevel, m.nCount
		Local DirArr,i,nTotDir,lvl,pkey
		m.path = Alltrim(m.path)

		If Parameters()<2 Or Type("m.nlevel") #"N"
			lvl = 0
		Else
			lvl = m.nlevel
		Endif

		If Parameters()<2 Or Type("m.nCount") #"N"
			Cnt = 0
		Else
			Cnt = m.nCount
		Endif

		lvl = lvl + 1
		Cnt = Cnt + 1
		pkey = Lower(Substr(m.path,1,Rat("\",m.path,2)))+"_"

		* Add items to treeview control
		o = This.oletreeview
		If Cnt = 1
			oNode = o.nodes.Add(,1,Lower(m.path)+"_",Lower(m.path),,)
			oNode.Image ="openfolder14"  &&14th icon of vfp graphics.. win95 folder
		Else
			oNode = o.nodes.Add(m.pkey,4,Lower(m.path)+"_",Lower(m.path),,)
			oNode.Image="openfolder2"   &&closeFolder"  &&can put many function of level cnt
		Endif

		Dimension DirArr[1,1]
		nTotDir=Adir(DirArr,m.path+"*.","D")
		Asort(DirArr)

		For i = 1 To m.nTotDir
			If DirArr[m.i,1] != '.' And Atc('D',DirArr[m.i,5])#0
				This.filltree(m.path+DirArr[m.i,1]+'\', m.lvl, m.cnt)
			Endif
		Endfor
	Endproc

	Procedure ycolor
		&&from Doug Henning and same article in  http://support.microsoft.com/kb/178491
		Lparameters toTree, ;
			tnColor
		Local lnhWnd, ;
			loNode, ;
			lnStyle
		* Declare some Windows API functions and constants we need.
		Declare Long GetWindowLong In Win32API Long HWnd, Long nIndex
		Declare Long SetWindowLong In Win32API Long HWnd, Long nIndex, ;
			long dwNewLong
		Declare SendMessage In Win32API Long HWnd, Long Msg, Long wParam, ;
			long Lparam
		#Define GWL_STYLE -16
		#Define TVM_SETBKCOLOR 4381
		#Define TVS_HASLINES 2

		* Get the TreeView's window handle.
		lnhWnd = toTree.HWnd

		* Set the BackColor for every node.
		For Each loNode In toTree.nodes
			loNode.BackColor = tnColor
		Next loNode

		* Set the BackColor for the TreeView's window.
		SendMessage(lnhWnd, TVM_SETBKCOLOR, 0, tnColor)

		* Get the current style, then temporarily hide lines and redisplay them so
		* they'll redraw in the new color.
		lnStyle = GetWindowLong(lnhWnd, GWL_STYLE)
		SetWindowLong(lnhWnd, GWL_STYLE, Bitxor(lnStyle, TVS_HASLINES))
		SetWindowLong(lnhWnd, GWL_STYLE, lnStyle)
	Endproc

	Procedure zcolor
		Lparameters toTree, ;
			tnColor
		Local lnhWnd, ;
			loNode, ;
			lnStyle
		* Declare some Windows API functions and constants we need.
		Declare Long GetWindowLong In Win32API Long HWnd, Long nIndex
		Declare Long SetWindowLong In Win32API Long HWnd, Long nIndex, ;
			long dwNewLong
		Declare SendMessage In Win32API Long HWnd, Long Msg, Long wParam, ;
			long Lparam
		#Define GWL_STYLE -16
		#Define TVM_SETBKCOLOR 4381
		#Define TVS_HASLINES 2
		#Define TVM_SETTEXTCOLOR 0x111E

		*!define TVM_SETBKCOLOR 0x111D ;Window Message Background
		*!define TVM_SETTEXTCOLOR 0x111E ;Window Message Text

		* Get the TreeView's window handle.
		lnhWnd = toTree.HWnd
		* Set the BackColor for every node.
		For Each loNode In toTree.nodes
			loNode.ForeColor = tnColor
		Next loNode
		* Set the BackColor for the TreeView's window.
		SendMessage(lnhWnd, TVM_SETTEXTCOLOR, 0, tnColor)

		* Get the current style, then temporarily hide lines and redisplay them so
		* they'll redraw in the new color.
		lnStyle = GetWindowLong(lnhWnd, GWL_STYLE)
		SetWindowLong(lnhWnd, GWL_STYLE, Bitxor(lnStyle, TVS_HASLINES))
		SetWindowLong(lnhWnd, GWL_STYLE, lnStyle)
	Endproc

	Procedure yactions
		Lparameters yindex
		Messagebox("-node index="+Trans(yindex)+  " --- execute any vfp action from here",0+32+4096,"",2000)

		*can make actions to execute from here
		*do case
		*case yindex=1
		*execute any action....
		*case yindex=2
		*...........
		*case yindex=n
		*....
		*endcase
	Endproc

	Procedure my1
		Thisform.LockScreen=.T.

		With yslave
			If ymaster.WindowState=1
				.Hide()
			Else
				.Top=This.Top
				.Left=This.Left
				.Width=This.Width
				.Height=This.Height
				.Show()
			Endi
		Endwith
		Thisform.LockScreen=.F.
	Endproc

	Procedure Destroy
		Set Defa To (yrep)
		Clear Events
	Endproc

	Procedure Unload
		yslave.Release
	Endproc

	Procedure Init

		m.yrep=Addbs(Justpath(Sys(16,1 )))     && for form :sys(1271,this)))
		Set Default To (yrep)

		This.SetAll("mousepointer",15,"commandbutton")
		This.SetAll("mousepointer",15,"checkBox")

		If  Fontmetric(1, 'MS Sans Serif', 8, '') # 13 Or ;
				fontmetric(4, 'MS Sans Serif', 8, '') # 2 Or ;
				fontmetric(6, 'MS Sans Serif', 8, '') # 5 Or ;
				fontmetric(7, 'MS Sans Serif', 8, '') # 11
			This.SetAll('fontname', 'Tahoma')
		Else
			This.SetAll('fontname','MS Sans Serif')
		Endif
		This.SetAll('fontsize',8)
		This.label1.FontSize=18
		* Check to see if OCX installed and loaded.
		If Type("THIS.oleTreeview") # "O" Or Isnull(This.oletreeview)
			Return .F.
		Endif
		* Check to see if OCX installed and loaded.
		If Type("THIS.oleImagesList") # "O" Or Isnull(This.oleimageslist)
			Return .F.
		Endif

		This.oletreeview.ImageList = This.oleimageslist   &&.object

		#Define LWA_COLORKEY 1
		#Define LWA_ALPHA 2
		#Define GWL_EXSTYLE -20
		#Define WS_EX_LAYERED 0x80000

		Local nExStyle, nRgb, nAlpha, nFlags
		nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE)
		nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
		= SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle)
		= SetLayeredWindowAttributes(Thisform.HWnd, 0, 200,LWA_ALPHA)   &&LWA_COLORKEY+

		Do yslave.prg  With This.Top,This.Left,This.Width,This.Height-Thisform.cmdgetdir.Height-5

		Bindevent(Thisform,"moved",Thisform,"my1")
		Bindevent(Thisform,"resize",Thisform,"my1")
	Endproc

	Procedure Load
		Publi m.yrep, yfolderIcons,m.gnbre
		m.gnbre=0
		m.yfolderIcons=Home(4)+"icons\win95\"   &&folder where the icons stay.HERE its for ex. in the vfp9 graphics icons folder

		Declare Integer GetWindowLong In user32;
			INTEGER HWnd, Integer nIndex

		Declare Integer SetWindowLong In user32;
			INTEGER HWnd, Integer nIndex, Integer dwNewLong

		Declare Integer SetLayeredWindowAttributes In user32;
			INTEGER HWnd, Integer crKey,;
			SHORT bAlpha, Integer dwFlags

		Declare Integer Sleep In kernel32 Integer
	Endproc

	Procedure oleimageslist.Init
		With This
			.ImageHeight = 16
			.ImageWidth =  16
			gnbre=Adir(gabase,m.yfolderIcons+"*.ico")
			xx=""
			For i=1 To gnbre
				.ListImages.Add(,"openfolder"+Trans(i),LoadPicture(m.yfolderIcons+gabase(i,1)) ) &&populate the imagelist object with desired icons
				Sleep(10)
			Endfor
		Endwith
		Sleep(100)
	Endproc

	Procedure oletreeview.NodeClick
		*** Événement de contrôle ActiveX  ***
		Lparameters Node
		Thisform.yactions(Node.Index)
	Endproc

	Procedure oletreeview.Init
		With This
			.HotTracking = .T.
			.Indentation = 20
			.LabelEdit = 1		&& no edit
			.lineStyle=1
			.Style=7
			.Scroll = .T.
		Endwith

		This.ImageList = Thisform.oleimageslist.Object
	Endproc

	Procedure text1.Init
		With This
			.		FontName = "MS Sans Serif"
			.		FontSize = 8
			.		Enabled = .F.
			.		Height = 23
			.		DisabledForeColor = Rgb(0,0,0)
			.		Name = "Text1"
		Endwith
	Endproc

	Procedure cmdgetdir.Init
		With This
			.FontName = "MS Sans Serif"
			.FontSize = 8
			.Caption = "\<Directory..."
			.Name = "cmdGetDir"
		Endwith
	Endproc

	Procedure cmdgetdir.Click
		Local cDir
		Set Defa To Home(1)
		cDir = Getdir()
		If Empty(m.cDir)
			Return
		Endif

		Thisform.text1.Value = m.cDir
		Thisform.oletreeview.nodes.Clear
		Thisform.filltree(m.cDir)

		Thisform.cmdch.Enabled=.T.
		Thisform.cmdch.Click()

		Thisform.Caption="Treeview ["+Trans(Thisform.oletreeview.nodes.Count)+" nodes]"
	Endproc

	Procedure cmdch.Click

		j=1
		For i=1 To Thisform.oletreeview.nodes.Count
			oNode=Thisform.oletreeview.nodes(i)
			If j>gnbre
				j=1
			Endi

			oNode.Image ="openfolder"+Trans(j)
			j=j+1
		Endfor
		Thisform.oletreeview.nodes(1).Image="openfolder14"
	Endproc

	Procedure cmdch.Init
		With This
			.FontName = "MS Sans Serif"
			.FontSize = 8
			.Caption = "\<Change icon..."
			.Enabled=.F.
			.Visible=.F.
			.Name = "cmdCh"
		Endwith
	Endproc

	Procedure command3.Init
		With This
			.FontBold = .T.
			.Caption = "Expand All Nodes"
			.ToolTipText = "Expands all nodes (Expanded property set to .T.)"
			.Name = "cmdExpandCollapse"
		Endwith

	Endproc

	Procedure command3.Click

		If Thisform.oletreeview.nodes.Count > 0
			* only do this if we have nodes in the treeview
			For Each loNode In Thisform.oletreeview.nodes
				If loNode.Children > 0
					* only do this if this node has child nodes
					loNode.Expanded = !Thisform.lexpanded
				Endif
			Endfor
			* set form's Expanded property to new value
			Thisform.lexpanded = !Thisform.lexpanded
			* update Caption for this command button
			This.Caption = Iif(Thisform.lexpanded,"Collapse","Expand") + " All Nodes"
			* update ToolTipText property
		Endif
	Endproc

	Procedure command1.Click
		Local xcolor
		m.xcolor=Getcolor()
		If Not Empty(m.xcolor) And m.xcolor#-1
			Thisform.ycolor(Thisform.oletreeview,m.xcolor)
		Endi
	Endproc

	Procedure command2.Click
		xcolor=Getcolor()
		If Empty(xcolor) And m.xcolor#-1
			Return .F.
		Endi


		If Thisform.oletreeview.nodes.Count > 0
			i=0
			For Each loNode In Thisform.oletreeview.nodes
				i=i+1
				Thisform.oletreeview.nodes(i).ForeColor=m.xcolor
			Endfor
			Thisform.oletreeview.Refresh
		Endif
	Endproc

	Procedure command4.Click
		Local xcolor
		m.xcolor=Getcolor()
		If Not Empty(xcolor) And m.xcolor#-1
			Thisform.zcolor(Thisform.oletreeview,m.xcolor)
		Endi
	Endproc

	Procedure command5.Click
		*CreateFont $1 "Comic Sans Ms" 8 0
		*SendMessage $0 ${WM_SETFONT} $1 0
		Messagebox("fontname="+Thisform.oletreeview.Font.Name+Chr(13)+"size="+Trans(Thisform.oletreeview.Font.Size,"999") ,0+32,"font set")
		x=Getfont()
		Try
			Thisform.oletreeview.Font.Name=Getwordnum(x,1,",")
			Thisform.oletreeview.Font.Size=Getwordnum(x,2,",")
		Catch
		Endtry
	Endproc

	Procedure check1.Click

		Thisform.oletreeview.Font.bold=!Thisform.oletreeview.Font.bold
	Endproc

	Procedure check2.Click
		Thisform.oletreeview.Font.Italic=!Thisform.oletreeview.Font.Italic
	Endproc

	Procedure check3.Click
		Thisform.oletreeview.Font.UnderLine=!Thisform.oletreeview.Font.UnderLine
	Endproc

	Procedure command6.Click
		Local xcolor
		m.xcolor=Getcolor()
		If Not Empty(m.xcolor) And m.xcolor#-1
			yslave.image1.Visible=.F.
			yslave.BackColor=m.xcolor
		Endi
	Endproc
	Procedure command7.Click
		yslave.image1.Picture=Getpict()
		yslave.image1.Visible=.T.
	Endproc

	Procedure optiongroup1.Option1.Click
		yslave.image1.Visible=!yslave.image1.Visible
	Endproc

	Procedure label1.Click
		Local m.myvar
		TEXT to m.myvar textmerge noshow
This buid a treeview (version6.0   )
The MSCOMCTL32 treeview have a bug in painting with API its
backcolor.there is some area not painting.I guess there is no
no correction of this bug at this time.
One solution is to embed same  treeview but version5.

To replace this effect and more i make :
-a second form "yslave"(alwaysonBottom=.t.) and bindevent the ymaster
form (events:resize,moved) to have always this form glued  behind
the first form (alwaysontop=.t.).the 2 forms are top evel.
i  apply to master form some transparency (color+alpha).
i can change (at runtime) the (backcolor & picture properties) of
yslave form.
With this i can have a semi transparent treeview with alpha
backcolor and alpha picture

Author: Yousfi Benameur El Bayadh Algeria
	Foxite 09 november 2014
		ENDTEXT
		Messagebox(m.myvar,0+32+4096,"Summary Help")
	Endproc

Enddefine
*

*End code ymaster.prg



this is a picture for demo test.download it.

this is a picture for demo test.download it.

Click on code to select [then copy] -click outside to deselect


*save this code as yslave.prg  in same folder

*Begin code yslave
Parameters xtop,xleft,xwidth,xheight
If Pcount()<>4
    Return .F.
Endif

yslave=Newobject("yslave_")
yslave.Show(1)
Retu
*
Define Class yslave_ As Form
	BorderStyle = 3
	Top = 1
	Left = 75
	Height = 358
	Width = 382
	ShowWindow = 2
	ShowInTaskbar = .F.
	Caption = ""
	ControlBox = .F.
	AlwaysOnBottom = .T.
	Name = "yslave"

	Add Object image1 As Image With ;
		Anchor = 15, ;
		Stretch = 2, ;
		Height = 360, ;
		Left = 0, ;
		Top = 0, ;
		Visible = .F., ;
		Width = 385, ;
		Name = "Image1"

	Procedure Init
		With Thisform
			.Top    =xtop
			.Left   =xleft
			.Width  =xwidth
			.Height =xheight
			.BackColor=255
		Endwith
	Endproc

Enddefine
*Endcode yslave



this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)
this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)
this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)
this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)
this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)

this is a vfp olecontrol treeview with a similar background image.(initially in visaul forms ,a container embed all controls.)

To be informed of the latest articles, subscribe:
Comment on this post