A basic vfp richtextbox implementation

Published on December 23 2015 by Yousfi Benameur


this code implements a basic richtextbox as a pure vfp solution.
All the main idea consists in making each word of a text in a label control and then use the label properties to beautify the text.
It's very fast contrary to what one may think.
I used bindevent but can use a label class to do the job.
Each word can be traversed with:
        .fontname
	.fontsize
	.fontstyle (N,B,BI,U,S)
	.forecolor
	.backcolor
	.backstyle
	.borderStyle
Each label must be mandatory with autosize=.t.
Each chr(13) in original text  is replaced by " | " to preserve the line feeds.
rightclick on any element to fire the contextuel menu and then can change its properties.The contextuel menu is created dynamicaly by the code.
after changing fontsize of any label can re Arrange the text in the contextuel menu.
all the labels are gathered in a container.Infortunatly the native one is not scrollable (must add a new class for that...its not the goal here.)
to make the solution perfect and load a big text.
the text generated is readOnly (note there is no edition functions as select,copy,paste..)...Of course , its a starting idea to develop....

i added in the second code below a routine to make the mouseWhell events.
This code is tested on Win10 pro & vfp9sp2

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

 
 *1* yRichtext.prg
 
publi yform
yform=newObject("yRichtext")
yform.show
read events
retu
*
DEFINE CLASS yRichtext AS form
BorderStyle = 0
Height = 550
Width = 980
ShowWindow = 2
AutoCenter = .T.
Caption = "A basic VFP RichtextBox implementation"
MaxButton = .F.
xlmargin = .F.
xtmargin = .F.
xint = .F.
yborder = 0
Name = "Form1"

ADD OBJECT edit1 AS editbox WITH ;
    Height = 432, ;
	Left = 12, ;
	Top = 30, ;
	Width = 301, ;
    readonly=.t., ;
	Name = "Edit1"

ADD OBJECT container1 AS container WITH ;
	Top = 37, ;
	Left = 324, ;
	Width = 636, ;
	Height = 424, ;
	Name = "Container1"

ADD OBJECT command1 AS commandbutton WITH ;
	Top = 468, ;
	Left = 96, ;
	Height = 48, ;
	Width = 84, ;
	FontBold = .T., ;
	FontSize = 14, ;
	Caption = "Go", ;
	MousePointer = 15, ;
	ForeColor = RGB(255,0,0), ;
	BackColor = RGB(128,255,0), ;
	Name = "Command1"

ADD OBJECT label1 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 11, ;
	Caption = "", ;
	Height = 20, ;
	Left = 624, ;
	Top = 6, ;
	Width = 2, ;
	BackColor = RGB(255,255,128), ;
	Name = "Label1"

ADD OBJECT label2 AS label WITH ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontSize = 11, ;
	BackStyle = 1, ;
	Caption = "RightClick on any element above to fire the contextuel menu", ;
	Height = 20, ;
	Left = 440, ;
	Top = 468, ;
	Width = 429, ;
	BackColor = RGB(255,255,128), ;
	Name = "Label2"

ADD OBJECT image1 AS image WITH ;
	Height = 26, ;
	Left = 921, ;
	MousePointer = 15, ;
	Top = 3, ;
	Width = 36, ;
	Name = "Image1"

PROCEDURE my
	do yrichtext_label.mpr
ENDPROC

PROCEDURE yarrange
	local m.oo
	m.oo=thisform.container1
	rVal=strtran(thisform.edit1.value,chr(13)," | ")
	with thisform.edit1
	j=0
	for i=1 to getwordcount (m.rVal)
	with eval("oo.label"+trans(i))
	.caption=getwordnum(m.rVal,i)
	if i=1
	j=0
	.left=thisform.xlmargin
	.top=thisform.xtmargin
	else
	if allt(.caption)="|"
	j=j+1
	.left=thisform.xlmargin
	.top= thisform.xtmargin+j*.height
	.caption=""
	else
	.left=eval("oo.label"+trans(i-1)+".left")+eval("oo.label"+trans(i-1)+".width+thisform.xint")
	.top=eval("oo.label"+trans(i-1)+".top")
	endi
	endi

	endwith
	endfor
	endwith
ENDPROC

PROCEDURE Init
	with thisform
	.xlmargin=10
	.xtmargin=20
	.xint=5
	endwith

	local m.myvar
	text to  m.myvar noshow
	Qk02DAAAAAAAADYAAAAoAAAAIAAAACAAAAABABgAAAAAAAAMAAAAAAAAAAAAAAAAAAAAAAAA////////////////////////////////////////2tray8vLvr6+tra2srKysbGxsbGxs7OzuLi4w8PD0tLS////////////////////////////////////////////////////////////////////////4uLi19fXubm5mJiYfHx8ZmZmWVlZUlJSUVFRUVFRVFRUXV1dbm5uiIiIqKiox8fH4ODg////////////////////////////////////////////////////////4uLiwcHBl5eXsaSe1sK46tXK8NzR8NzR8NzR8NzR8NzR79vQ4MzAwK+lV1RSWFhYfX19p6enz8/P////////////////////////////////////////////////2trasLCwqqCZ69fM8uDW9Ojj9O/t9PTz8/T08PLz8fLz8fLz8vHx9O3p8+Xd7tvQzbuvX1lXXFxcj4+PwsLC////////////////////////////////////////19fXp6am4M3C8t/V9fDu8vT18PLz6+7v3+Lk3+Lj6Ovs7O/x7O/x7fDy7fDy7/Ly8/Lx9Onj79vQmImCS0tLg4ODvb295eXl////////////////////////////29vbtbCt6tbL9evl9PX18PHy7fHy5N3by6+ivotyv3xbwnhSxn1ZzI9x1auW387E6enp7fDy8PHy9vT08uHYv6yiRkZGgoKCwMDA////////////////////////////vbi179rP9vHv8/T08PT16ufm1auVwHFJu1sqvlonwGEzyIFfxnNJvFYju1gnvmI0yYdn3se87fDy7/Dx9Pb29Obewa6kSUlJjIyMy8vL////////////////////ycfG6tfM9/Ht9PX18PT15djRyIBdvVoov1sqw2AvwmY4xaqd7O7v9e3p0ohjwl0rwF4tvVknvWAy0aGJ6uno7/Hx9fb38+LZm4yEV1dXn5+f2tra////////////3Nzc4MzC9ujh9vf38vf44s3Bw21Dvloow2IxxmMyymIuvHdVwcTF+Pj5////6sq6x2MwxmMyxGIywF8uvFoozZBx7Orp8fLy9vf38N3ScmhjcXFxvLy8////////////y8TA8d7T+fn69Pb26NvVxG5DwFwqxWMyyGQzy2YzzWQxwG9Hv7u5/v//9fz/2aiPymIuymUzyGUzx2MxwmEwvFgm0Jh87u/w8vP09u7q3Mi9VFJRmZmZ2tra////////5tPI9+7p9vj58fHwzohmwFwpxmQzyWU0zGc0zGc0zGYzy2QwyYVj6ci33aiPy2g2zGQxzGY0zGY0yWUzxmMzwmAvvl0s3Lmo8fX39fb38t/VeW5pdXV1xMTE////////79vQ+fr59vr74cGxwl8vxmMyymY0zGc1zGc0zGc0zGYzzGYyzWIsymAryl8qy2MvzGYzzGYzzGY0y2Y0ymUzx2QywF4txnZN6+bj8/X19u3o38vAWFhYra2t////9eXd9OXc+fr79PT00Illw14rymY1zWg2zWg1zGc0zGYzzGUyymc1y5V86cCs6sCq03xQy2IuzGYzzGYzzGc0zGc0ymU0xWMyv1wr3Laj9Pn79vb179rPWVZUmJiY29vb8t7T+O7p+v3+7dzUxmY2yGY0zWg2zWg2zWg1zGYzzGYzzGUyx2c3x7qz////////2pFryl8pzGYzzGYzzGc0zGc0y2Y0yGU0wVwozolm8fHx9/n68t/VmoyEiIiI09PT8dzR/Pj1/P//5LypxmIwzGk4z2o4zmg2zGYzzGYzzGYzzGYyyGUzwa6l/P7/////46qNyl0ozGYzzGYzzGYzzWc0zWg1y2c1xWAux3NJ7eTf9/n79ebev62lgICAzs7O8NzR/v39/v//36iOymUyz2s50Gs4zmg2zGYzzGYzzGYzzGYzzGMvuIx35Ors////+vHs2YxlymAszGYzzGYzzGc0zWg1zGg2yGQyxmk569vT9/r89enjyLetfX19zMzM8NzR//7+////36CBzmg10m480Ww6zmk2zGYzzGYzzGYzzGYzzWUxxmg5u6SZ8fb4////+vHs2ItlymArzGYzzGc0zmk2zmk3ymY0yGk569fN+fz+9+vlybeufn5+zMzM8NzR/v79////5KeJ0mw51XE/0247z2k2zGYzzGYzzGYzzGYzzGYzzWQvxWg5xK6i9vn7////+/Ht14dfy2ItzWc0z2k3z2s5zGg2yms77tvS/P//9+zlybiug4ODz8/P8dzR/vv7////7Lmf2HI+2nZE1nE+0Gs4zWc0zGYzzGYzzGYzzGYzzGYzzWQuxWk60b2z/P//////9eDXzm08zWUx0Ws40m07zmo3znFD9OXe////9+rjyLetjo6O1dXV8d3R/Pbz////+tvL33lG4HxK23ZE0207zmg1zGMuy2EsymAqy2QwzGYzzGYzzWMtxHRM7Ofl///////+3JRwzWMv0m071HA+z2k21oVc+/Xz////9eTcuamhoKCg////8+DV+Ozm/////vr37JFj6IJP435M2HI/z28/z5Bx2qaN57mj1H1Qy2ItzGYzzGYzymMw4c3C////////5LCV0Gcz1nI+2HRB0ms35auO//////7+8NzRmI6It7e3////9+ri9OLZ////////+8mu8YdS7opX43xI0nZIycK+8fb5////68Kuyl8py2Mvy2AsynBD7OLd////+fz936WJ1W043HdF3HhG2HZE+N/T/////fr57tnPhISEzs7O////////8NvQ/fr4//////fw/aN0/JVi9I9c5HtHxp+M8PX3/////v385rKZ0ndL0X9W5Me5/P7/////7e3s3I9q33ZB439N4HdE66uK////////9unhyriuqamp////////////7dzU9ujg/////////+PS/6Nu/6Nx+pVh4IpfzcbD+v3+/////////PXx+/j2////////9vv948q+5oNS7IZT64NP7JNm/fXu/////vz879vQl5KPysrK////////////////8NvQ/fr5/////////+HD/7WA/7SB/6Ju5qF+187L7vP19fn79/v99/v89/r88fb56djR8Zxz+JJe+pNg9pRh/uLS////////9+niz72zsbGx5OTk////////////////7eHa8+HX/////////////+vU/9Cc/8uX/7uH97OJ6b+q3ca+18fA18fA38m/8MGp/Kl8/6Nw/6Rv/65+/+jX/////////Pf17NjNp6Si19fX////////////////////////7t3T9ujg//////////////zt/+/G/+m0/92m/9Gb/8aW/r+P/b2M/72L/7uH/7yG/8KO/9Gv//z4/////////v398d3Ss6un0NDQ////////////////////////////////793U9ufg///////////////////t//3l//vR//bD/++7/+i1/+Sx/+a3/+vN//bo/////////////fn48d3TvbKtzs7O////////////////////////////////////////8+DW8+DW/Pf1///////////////////////9///9///8///8///9////////////////+O7o79vQwrq21NTU////////////////////////////////////////////////9ebe9ebe9ebe/Pj0/////////////////////////////////////vz7+vHs8t/V5NDGy8bD4ODg////////////////////////////////////////////////////////////7t3U79zQ8+DV9unh+vLu/fr5/vz7/vz7/Pf2+e7p9eXd79vQ6NXK0cfC////////////////////////////////////////////////////////////////////////////////////9OPa8t7T8d3S8d3S8d3S8d3S8t/U9ube////////////////////////////////////////////////////
	endtext
	thisform.image1.pictureVal=strconv(m.myvar,14)
ENDPROC

PROCEDURE Load
	local m.myvar
	text to m.myvar noshow
	*
	DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
	DEFINE BAR 1 OF raccourci PROMPT "change forecolor"
	DEFINE BAR 2 OF raccourci PROMPT "change backcolor"
	DEFINE BAR 3 OF raccourci PROMPT "change fontname"
	DEFINE BAR 4 OF raccourci PROMPT "change fontsize"
	DEFINE BAR 5 OF raccourci PROMPT "change style"
	DEFINE BAR 6 OF raccourci PROMPT "Backstyle"
	DEFINE BAR 7 OF raccourci PROMPT "border"
	DEFINE BAR 8 OF raccourci PROMPT "All text"
	DEFINE BAR 9 OF raccourci PROMPT "Re Arrange"
	ON SELECTION BAR 1 OF raccourci ;
		DO _4iu1afuxf 
	ON SELECTION BAR 2 OF raccourci ;
		DO _4iu1afuxi  
	ON SELECTION BAR 3 OF raccourci ;
		DO _4iu1afuxj  
	ON SELECTION BAR 4 OF raccourci ;
		DO _4iu1afuxl  
	ON SELECTION BAR 5 OF raccourci ;
		DO _4iu1afuxo 
	ON SELECTION BAR 6 OF raccourci ;
		DO _4iu1afuxq 
	ON SELECTION BAR 7 OF raccourci ;
		DO _4iu1afuxr 
        
	ON BAR 8 OF raccourci ACTIVATE POPUP alltext
	ON SELECTION BAR 9 OF raccourci _screen.activeForm.yArrange()

	DEFINE POPUP alltext SHORTCUT RELATIVE
	DEFINE BAR 1 OF alltext PROMPT "All forecolor"
	DEFINE BAR 2 OF alltext PROMPT "All Backcolor"
	DEFINE BAR 3 OF alltext PROMPT "All borders"
	DEFINE BAR 4 OF alltext PROMPT "Random forecolors"
	DEFINE BAR 5 OF alltext PROMPT "Random backcolors"
	DEFINE BAR 6 OF alltext PROMPT "fontsize"
	ON SELECTION BAR 1 OF alltext ;
		DO _4iu1afuxt 
	ON SELECTION BAR 2 OF alltext ;
		DO _4iu1afuxx
	ON SELECTION BAR 3 OF alltext ;
		DO _4iu1afuxz 
	ON SELECTION BAR 4 OF alltext ;
		DO _4iu1afuy2 
	ON SELECTION BAR 5 OF alltext ;
		DO _4iu1afuy3 
	ON SELECTION BAR 6 OF alltext ;
		DO _4iu1bv648 

	ACTIVATE POPUP raccourci
	*
PROCEDURE _4iu1afuxf
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]
	local m.xcolor
	m.xcolor=getcolor()
	if !m.xcolor=-1
	loObject.forecolor=m.xcolor
	endi
	*
PROCEDURE _4iu1afuxi
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]
	m.xcolor=getcolor()
	if m.xcolor=-1
	return .f.
	endi
	with loObject
	.backcolor=m.xcolor
	.backstyle=1
	endwith
	*
PROCEDURE _4iu1afuxj
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]


	local m.x,xfontname
	m.x=getfont()
	if empty(m.x)
	return .f.
	endi
	m.xfontname=getwordnum(m.x,1,",")
	loObject.fontname=m.xfontname

	*
PROCEDURE _4iu1afuxl
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]
	local m.x,xfontsize
	m.x=getfont()
	if empty(m.x)
	return .f.
	endi
	m.xfontsize=getwordnum(m.x,2,",")
	loObject.fontsize=int(val(m.xfontsize))

	*
PROCEDURE _4iu1afuxo
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]
	local m.x,xfontstyle
	m.x=getfont()
	if empty(m.x)
	return .f.
	endi
	m.xfontstyle=getwordnum(m.x,3,",")
	do case
	case empty(m.xfontstyle) or m.xfontstyle="N"
	with loObject
	.fontbold=.f.
	.fontitalic=.f.
	.fontUnderline=.f.
	.fontStrikethru=.f.
	endwith

	case m.xfontstyle=="B"
	loObject.fontbold=.t.

	case m.xfontStyle=="I"
	loObject.fontItalic=.t.

	case m.xfontstyle=="BI"
	loObject.fontbold=.t.
	loObject.fontItalic=.t.

	case m.xfontstyle=="U"
	loObject.fontUnderLine=.t.

	case m.xfontStyle=="S"     &&Strikethru
	loObject.fontStrikethru=.t.

	otherwise
	with loObject
	.fontbold=.f.
	.fontitalic=.f.
	.fontUnderline=.f.
	endwith
	endcase

	*
PROCEDURE _4iu1afuxq
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]
loObject.backstyle=iif(loObject.backStyle=0,1,0)

	*
PROCEDURE _4iu1afuxr
	*--- aevent create an array laEvents
	   Aevents( myArray, 0)
	 *--- reference the calling object
		loObject = myArray[1]

	with loObject
	.borderStyle=iif(.borderstyle=0,1,0)
	endwith
	*
PROCEDURE _4iu1afuxt
	local m.xcolor
	m.xcolor=getcolor()
	if m.xcolor=-1
	return .f.
	endi

	with _screen.activeform.container1
	for i=1 to .controlcount
	loObject=eval(".label"+trans(i))
	loObject.forecolor=m.xcolor
	endfor
	endwith

	*
PROCEDURE _4iu1afuxx
	local m.xcolor
	m.xcolor=getcolor()
	if m.xcolor=-1
	return .f.
	endi

	with  _screen.activeform.container1
	for i=1 to .controlcount
	loObject=eval(".label"+trans(i))
	loObject.backcolor=m.xcolor
	loObject.backstyle=1
	endfor
	endwith
	
	*
PROCEDURE _4iu1afuxz
	with _screen.activeform.container1
	.parent.yborder=iif(.parent.yborder=0,1,0)

	if  .parent.yborder=1
	.setall("borderstyle",1,"label")
	else
	.setall("borderstyle",0,"label")
	endi
	endwith

	*
PROCEDURE _4iu1afuy2
	with  _screen.activeform.container1
	for i=1 to .controlcount
	loObject=eval(".label"+trans(i))
	loObject.forecolor=rgb(255*rand(),255*rand(),255*rand())    &&random forecolor
	endfor
	endwith

PROCEDURE _4iu1afuy3
	with  _screen.activeform.container1
	for i=1 to .controlcount
	loObject=eval(".label"+trans(i))
	loObject.Backcolor=rgb(255*rand(),255*rand(),255*rand())    &&random backcolor
	loObject.backStyle=1
	endfor
	endwith

	*
PROCEDURE _4iu1bv648
	local m.xfontsize
	m.xfontsize=int(val(inputBox("Set an unique fontsize","","12")))
	with  _screen.activeform.container1
	for i=1 to .controlcount
	loObject=eval(".label"+trans(i))
	loObject.fontsize=m.xfontsize
	endfor
	endwith

	endtext
	set safe off
	strtofile(m.myvar,"yRichtext_Label.mpr")
ENDPROC

PROCEDURE edit1.Init
	TEXT to this.value noshow
	Lorem ipsum dolor sit amet, consectetur adipiscing elit.
	Proin vel risus eget lorem feugiat fermentum nec a turpis.
	Phasellus purus sem, mollis ac posuere eget, ornare vel orci.
	Sed ac rutrum nulla. Aenean ultrices eget lectus eu efficitur.
	In hac habitasse platea dictumst. Nulla in iaculis nisi.
	Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non,
	porta congue dolor. Aenean viverra auctor sagittis.
	Integer lobortis dignissim auctor. Proin et volutpat massa.
	Cras vitae felis venenatis, egestas sem quis, sodales neque.
	Donec venenatis hendrerit odio, non pellentesque metus scelerisque ac.
	Suspendisse aliquet rhoncus odio id viverra.
	Vestibulum feugiat lectus a nisl pulvinar, in tempor metus eleifend.
	Nunc id odio quam. Praesent egestas lorem ut sollicitudin consectetur.
	Vestibulum id bibendum est. Ut vel lacus sapien.
	Quisque eget molestie sem. Integer eget purus eu orci molestie
	aliquam quis in ante. Integer a magna eget lectus finibus porttitor.
	Donec fringilla sapien a quam aliquet, pellentesque blandit
	nisl placerat. Nam hendrerit velit vel ex aliquam, eget convallis ante mollis.
	ENDTEXT
ENDPROC


PROCEDURE command1.Click
	this.enabled=.f.

	local m.oo,m.rVal
	m.oo=thisform.container1
	m.rVal=strtran(thisform.edit1.value,chr(13)," | ")
	thisform.label1.caption=trans(getwordcount (m.rVal))+" words."
	with thisform.edit1
	j=0
	for i=1 to getwordcount (m.rVal)
	oo.addobject("label"+trans(i),"label")
	with eval("oo.label"+trans(i))
	.caption=getwordnum(m.rVal,i)
	if i=1
	j=0
	.left=thisform.xlmargin
	.top=thisform.xtmargin
	else
	if allt(.caption)="|"
	j=j+1
	.left=thisform.xlmargin
	.top= thisform.xtmargin+j*.height
	.caption=""
	else
	.left=eval("oo.label"+trans(i-1)+".left")+eval("oo.label"+trans(i-1)+".width+thisform.xint")
	.top=eval("oo.label"+trans(i-1)+".top")
	endi
	endi

	.fontbold=.t.
	.forecolor=0
	.backcolor=thisform.backcolor
	.borderstyle=0
	.autosize=.t.
	.alignment=0
	.backstyle=0
	.fontcharset=1
	.fontname="Arial"
	.fontsize=12
	.rotation=0
	.wordwrap=.f.
	.visible=.t.
	endwith
	bindevent(eval("oo.label"+trans(i)),"rightclick",thisform,"my")
	endfor
	endwith
ENDPROC

PROCEDURE image1.Click
	local m.myvar
	text to m.myvar noshow
this code implements a basic richtextbox as a pure vfp solution.
it consists in making each word of a text in a label control and
then use the label properties to beautify the text.
It's very fast contrary to what one may think
each word can be traversed with:
	.fontname
	.fontsize
	.fontstyle (N,B,BI,U,S)
	.forecolor
	.backcolor
	.backstyle
	.borderStyle
the label must be mandatory with autosize=.t.
Each chr(13) in original text  is repaced by " | " to preserve the line feeds.
rightclick on any element to fire the contextuel menu and then can change its properties.
after changing fontsize of any label can re Arrange the text in the contextuel menu.
all the labels are gathered in a container.Infortunatly the native one is
not scrollable (must adda new class for that...its not the goal here.)
to make the solution perfect and load a big text.
	endtext
	messagebox(m.myvar,0+64+4096,"Summary help")

ENDPROC

PROCEDURE DESTROY
CLEA EVENTS
ENDPROC

ENDDEFINE
*
*-- EndDefine: yRichText

Note: Instead of the static container shown in the code above, can use a scrollable container as in this link:
http://www.sweetpotatosoftware.com/spsblog/2005/08/27/VisualFoxProScrollbarClasses.aspx
simply download the class (46ko) and adapt it .with this vfp tool can use big text on the demo.

*this is solved in the code *2* below

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

 

*2* yRichtext_update.prg
*download the vfpscrollbar.zip and keep only the vfpscrollbar.vcx(+vct)
*from http://www.sweetpotatosoftware.com/spsblog/2005/08/27/VisualFoxProScrollbarClasses.aspx
*and run this code.the text can be now scrolled V & H.
*for big fontsize must adjust the properties xint and delta

set classlib to locfile("vfpScrollbar.vcx") addi
publi yform
yform=newObject("yRichtext")
release classlib vfpscrollbar
yform.show
read events
retu
*
DEFINE CLASS yRichtext AS form
BorderStyle = 0
Height = 550
Width = 980
ShowWindow = 2
AutoCenter = .T.
Caption = "A basic VFP scrollable RichtextBox implementation"
MaxButton = .F.
xlmargin = .F.
xtmargin = .F.
xint = .F.   &&adjust space between words ...
xdelta=10    &&can adjust  the space between lines....
yborder = 0
Name = "Form1"

ADD OBJECT edit1 AS editbox WITH ;
Height = 432, ;
Left = 12, ;
Top = 30, ;
Width = 301, ;
readonly=.t., ;
Name = "Edit1"

ADD OBJECT container1 AS Sbscrollcontainer WITH ;
Top = 37, ;
Left = 324, ;
Width = 636, ;
Height = 424, ;
Name = "Container1"

ADD OBJECT command1 AS commandbutton WITH ;
Top = 468, ;
Left = 96, ;
Height = 48, ;
Width = 84, ;
FontBold = .T., ;
FontSize = 14, ;
Caption = "Go", ;
MousePointer = 15, ;
ForeColor = RGB(255,0,0), ;
BackColor = RGB(128,255,0), ;
Name = "Command1"

ADD OBJECT label1 AS label WITH ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
Caption = "", ;
Height = 20, ;
Left = 624, ;
Top = 6, ;
Width = 2, ;
BackColor = RGB(255,255,128), ;
Name = "Label1"

ADD OBJECT label2 AS label WITH ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
BackStyle = 1, ;
Caption = "RightClick on any element above to fire the contextuel menu", ;
Height = 20, ;
Left = 440, ;
Top = 468, ;
Width = 429, ;
BackColor = RGB(255,255,128), ;
Name = "Label2"

ADD OBJECT image1 AS image WITH ;
Height = 26, ;
Left = 921, ;
MousePointer = 15, ;
Top = 3, ;
Width = 36, ;
Name = "Image1"

procedure  container1.mouseWheel   &&i added this to mouseWheel event in scrolling container
LPARAMETERS nDirection, nShift, nXCoord, nYCoord
dodefault()
local m.n
m.n=10
if nDirection>0
for i=1 to n
this.scrollBarVertical1.ScrollEndUp1.SbShape4.click
endfor
else
for i=1 to n
this.scrollBarVertical1.ScrollEndDown1.SbShape4.click
endfor
endi
endproc

PROCEDURE my
do yrichtext_label.mpr
ENDPROC

PROCEDURE yarrange
local m.oo
m.oo=thisform.container1
rVal=strtran(thisform.edit1.value,chr(13)," | ")
with thisform.edit1
j=0
try
for i=1 to getwordcount (m.rVal)

with eval("oo.label"+trans(i))
.caption=getwordnum(m.rVal,i)
if i=1
j=0
.left=thisform.xlmargin
.top=thisform.xtmargin
else
if allt(.caption)="|"
j=j+1
.left=thisform.xlmargin
.top= thisform.xtmargin+j*.height
.caption=""
else
.left=eval("oo.label"+trans(i-1)+".left")+eval("oo.label"+trans(i-1)+".width+thisform.xint")
.top=eval("oo.label"+trans(i-1)+".top"+thisform.xdelta)
endi
endi

endwith
endfor
catch
endtry
endwith
ENDPROC

PROCEDURE Init
dodefault()
with thisform
.xlmargin=10
.xtmargin=20
.xint=5
endwith

local m.myvar
text to  m.myvar noshow
Qk02DAAAAAAAADYAAAAoAAAAIAAAACAAAAABABgAAAAAAAAMAAAAAAAAAAAAAAAAAAAAAAAA////////////////////////////////////////2tray8vLvr6+tra2srKysbGxsbGxs7OzuLi4w8PD0tLS////////////////////////////////////////////////////////////////////////4uLi19fXubm5mJiYfHx8ZmZmWVlZUlJSUVFRUVFRVFRUXV1dbm5uiIiIqKiox8fH4ODg////////////////////////////////////////////////////////4uLiwcHBl5eXsaSe1sK46tXK8NzR8NzR8NzR8NzR8NzR79vQ4MzAwK+lV1RSWFhYfX19p6enz8/P////////////////////////////////////////////////2trasLCwqqCZ69fM8uDW9Ojj9O/t9PTz8/T08PLz8fLz8fLz8vHx9O3p8+Xd7tvQzbuvX1lXXFxcj4+PwsLC////////////////////////////////////////19fXp6am4M3C8t/V9fDu8vT18PLz6+7v3+Lk3+Lj6Ovs7O/x7O/x7fDy7fDy7/Ly8/Lx9Onj79vQmImCS0tLg4ODvb295eXl////////////////////////////29vbtbCt6tbL9evl9PX18PHy7fHy5N3by6+ivotyv3xbwnhSxn1ZzI9x1auW387E6enp7fDy8PHy9vT08uHYv6yiRkZGgoKCwMDA////////////////////////////vbi179rP9vHv8/T08PT16ufm1auVwHFJu1sqvlonwGEzyIFfxnNJvFYju1gnvmI0yYdn3se87fDy7/Dx9Pb29Obewa6kSUlJjIyMy8vL////////////////////ycfG6tfM9/Ht9PX18PT15djRyIBdvVoov1sqw2AvwmY4xaqd7O7v9e3p0ohjwl0rwF4tvVknvWAy0aGJ6uno7/Hx9fb38+LZm4yEV1dXn5+f2tra////////////3Nzc4MzC9ujh9vf38vf44s3Bw21Dvloow2IxxmMyymIuvHdVwcTF+Pj5////6sq6x2MwxmMyxGIywF8uvFoozZBx7Orp8fLy9vf38N3ScmhjcXFxvLy8////////////y8TA8d7T+fn69Pb26NvVxG5DwFwqxWMyyGQzy2YzzWQxwG9Hv7u5/v//9fz/2aiPymIuymUzyGUzx2MxwmEwvFgm0Jh87u/w8vP09u7q3Mi9VFJRmZmZ2tra////////5tPI9+7p9vj58fHwzohmwFwpxmQzyWU0zGc0zGc0zGYzy2QwyYVj6ci33aiPy2g2zGQxzGY0zGY0yWUzxmMzwmAvvl0s3Lmo8fX39fb38t/VeW5pdXV1xMTE////////79vQ+fr59vr74cGxwl8vxmMyymY0zGc1zGc0zGc0zGYzzGYyzWIsymAryl8qy2MvzGYzzGYzzGY0y2Y0ymUzx2QywF4txnZN6+bj8/X19u3o38vAWFhYra2t////9eXd9OXc+fr79PT00Illw14rymY1zWg2zWg1zGc0zGYzzGUyymc1y5V86cCs6sCq03xQy2IuzGYzzGYzzGc0zGc0ymU0xWMyv1wr3Laj9Pn79vb179rPWVZUmJiY29vb8t7T+O7p+v3+7dzUxmY2yGY0zWg2zWg2zWg1zGYzzGYzzGUyx2c3x7qz////////2pFryl8pzGYzzGYzzGc0zGc0y2Y0yGU0wVwozolm8fHx9/n68t/VmoyEiIiI09PT8dzR/Pj1/P//5LypxmIwzGk4z2o4zmg2zGYzzGYzzGYzzGYyyGUzwa6l/P7/////46qNyl0ozGYzzGYzzGYzzWc0zWg1y2c1xWAux3NJ7eTf9/n79ebev62lgICAzs7O8NzR/v39/v//36iOymUyz2s50Gs4zmg2zGYzzGYzzGYzzGYzzGMvuIx35Ors////+vHs2YxlymAszGYzzGYzzGc0zWg1zGg2yGQyxmk569vT9/r89enjyLetfX19zMzM8NzR//7+////36CBzmg10m480Ww6zmk2zGYzzGYzzGYzzGYzzWUxxmg5u6SZ8fb4////+vHs2ItlymArzGYzzGc0zmk2zmk3ymY0yGk569fN+fz+9+vlybeufn5+zMzM8NzR/v79////5KeJ0mw51XE/0247z2k2zGYzzGYzzGYzzGYzzGYzzWQvxWg5xK6i9vn7////+/Ht14dfy2ItzWc0z2k3z2s5zGg2yms77tvS/P//9+zlybiug4ODz8/P8dzR/vv7////7Lmf2HI+2nZE1nE+0Gs4zWc0zGYzzGYzzGYzzGYzzGYzzWQuxWk60b2z/P//////9eDXzm08zWUx0Ws40m07zmo3znFD9OXe////9+rjyLetjo6O1dXV8d3R/Pbz////+tvL33lG4HxK23ZE0207zmg1zGMuy2EsymAqy2QwzGYzzGYzzWMtxHRM7Ofl///////+3JRwzWMv0m071HA+z2k21oVc+/Xz////9eTcuamhoKCg////8+DV+Ozm/////vr37JFj6IJP435M2HI/z28/z5Bx2qaN57mj1H1Qy2ItzGYzzGYzymMw4c3C////////5LCV0Gcz1nI+2HRB0ms35auO//////7+8NzRmI6It7e3////9+ri9OLZ////////+8mu8YdS7opX43xI0nZIycK+8fb5////68Kuyl8py2Mvy2AsynBD7OLd////+fz936WJ1W043HdF3HhG2HZE+N/T/////fr57tnPhISEzs7O////////8NvQ/fr4//////fw/aN0/JVi9I9c5HtHxp+M8PX3/////v385rKZ0ndL0X9W5Me5/P7/////7e3s3I9q33ZB439N4HdE66uK////////9unhyriuqamp////////////7dzU9ujg/////////+PS/6Nu/6Nx+pVh4IpfzcbD+v3+/////////PXx+/j2////////9vv948q+5oNS7IZT64NP7JNm/fXu/////vz879vQl5KPysrK////////////////8NvQ/fr5/////////+HD/7WA/7SB/6Ju5qF+187L7vP19fn79/v99/v89/r88fb56djR8Zxz+JJe+pNg9pRh/uLS////////9+niz72zsbGx5OTk////////////////7eHa8+HX/////////////+vU/9Cc/8uX/7uH97OJ6b+q3ca+18fA18fA38m/8MGp/Kl8/6Nw/6Rv/65+/+jX/////////Pf17NjNp6Si19fX////////////////////////7t3T9ujg//////////////zt/+/G/+m0/92m/9Gb/8aW/r+P/b2M/72L/7uH/7yG/8KO/9Gv//z4/////////v398d3Ss6un0NDQ////////////////////////////////793U9ufg///////////////////t//3l//vR//bD/++7/+i1/+Sx/+a3/+vN//bo/////////////fn48d3TvbKtzs7O////////////////////////////////////////8+DW8+DW/Pf1///////////////////////9///9///8///8///9////////////////+O7o79vQwrq21NTU////////////////////////////////////////////////9ebe9ebe9ebe/Pj0/////////////////////////////////////vz7+vHs8t/V5NDGy8bD4ODg////////////////////////////////////////////////////////////7t3U79zQ8+DV9unh+vLu/fr5/vz7/vz7/Pf2+e7p9eXd79vQ6NXK0cfC////////////////////////////////////////////////////////////////////////////////////9OPa8t7T8d3S8d3S8d3S8d3S8t/U9ube////////////////////////////////////////////////////
endtext
thisform.image1.pictureVal=strconv(m.myvar,14)
ENDPROC

PROCEDURE Load
set safe off
erase yRichtext_Label.mpr

local m.myvar
text to m.myvar noshow
*
DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR 1 OF raccourci PROMPT "change forecolor"
DEFINE BAR 2 OF raccourci PROMPT "change backcolor"
DEFINE BAR 3 OF raccourci PROMPT "change fontname"
DEFINE BAR 4 OF raccourci PROMPT "change fontsize"
DEFINE BAR 5 OF raccourci PROMPT "change style"
DEFINE BAR 6 OF raccourci PROMPT "Backstyle"
DEFINE BAR 7 OF raccourci PROMPT "border"
DEFINE BAR 8 OF raccourci PROMPT "All text"
DEFINE BAR 9 OF raccourci PROMPT "Re Arrange"
ON SELECTION BAR 1 OF raccourci ;
    DO _4iu1afuxf
ON SELECTION BAR 2 OF raccourci ;
	DO _4iu1afuxi
ON SELECTION BAR 3 OF raccourci ;
	DO _4iu1afuxj
ON SELECTION BAR 4 OF raccourci ;
	DO _4iu1afuxl
ON SELECTION BAR 5 OF raccourci ;
	DO _4iu1afuxo
ON SELECTION BAR 6 OF raccourci ;
	DO _4iu1afuxq
ON SELECTION BAR 7 OF raccourci ;
	DO _4iu1afuxr
	
ON BAR 8 OF raccourci ACTIVATE POPUP alltext
ON SELECTION BAR 9 OF raccourci _screen.activeForm.yArrange()

DEFINE POPUP alltext SHORTCUT RELATIVE
DEFINE BAR 1 OF alltext PROMPT "All forecolor"
DEFINE BAR 2 OF alltext PROMPT "All Backcolor"
DEFINE BAR 3 OF alltext PROMPT "All borders"
DEFINE BAR 4 OF alltext PROMPT "Random forecolors"
DEFINE BAR 5 OF alltext PROMPT "Random backcolors"
DEFINE BAR 6 OF alltext PROMPT "fontsize"
ON SELECTION BAR 1 OF alltext ;
	DO _4iu1afuxt
ON SELECTION BAR 2 OF alltext ;
	DO _4iu1afuxx
ON SELECTION BAR 3 OF alltext ;
	DO _4iu1afuxz
ON SELECTION BAR 4 OF alltext ;
	DO _4iu1afuy2
ON SELECTION BAR 5 OF alltext ;
	DO _4iu1afuy3
ON SELECTION BAR 6 OF alltext ;
	DO _4iu1bv648

ACTIVATE POPUP raccourci
*
PROCEDURE _4iu1afuxf
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]
local m.xcolor
m.xcolor=getcolor()
if !m.xcolor=-1
loObject.forecolor=m.xcolor
endi
*
PROCEDURE _4iu1afuxi
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]
m.xcolor=getcolor()
if m.xcolor=-1
return .f.
endi
with loObject
.backcolor=m.xcolor
.backstyle=1
endwith
*
PROCEDURE _4iu1afuxj
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]

local m.x,xfontname
m.x=getfont()
if empty(m.x)
return .f.
endi
m.xfontname=getwordnum(m.x,1,",")
loObject.fontname=m.xfontname

*
PROCEDURE _4iu1afuxl
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]
local m.x,xfontsize
m.x=getfont()
if empty(m.x)
return .f.
endi
m.xfontsize=getwordnum(m.x,2,",")
loObject.fontsize=int(val(m.xfontsize))

*
PROCEDURE _4iu1afuxo
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]
local m.x,xfontstyle
m.x=getfont()
if empty(m.x)
return .f.
endi
m.xfontstyle=getwordnum(m.x,3,",")
do case
case empty(m.xfontstyle) or m.xfontstyle="N"
with loObject
.fontbold=.f.
.fontitalic=.f.
.fontUnderline=.f.
.fontStrikethru=.f.
endwith

case m.xfontstyle=="B"
loObject.fontbold=.t.

case m.xfontStyle=="I"
loObject.fontItalic=.t.

case m.xfontstyle=="BI"
loObject.fontbold=.t.
loObject.fontItalic=.t.

case m.xfontstyle=="U"
loObject.fontUnderLine=.t.

case m.xfontStyle=="S"     &&Strikethru
loObject.fontStrikethru=.t.

otherwise
with loObject
.fontbold=.f.
.fontitalic=.f.
.fontUnderline=.f.
endwith
endcase

*
PROCEDURE _4iu1afuxq
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]
loObject.backstyle=iif(loObject.backStyle=0,1,0)

*
PROCEDURE _4iu1afuxr
*--- aevent create an array laEvents
   Aevents( myArray, 0)
 *--- reference the calling object
	loObject = myArray[1]

with loObject
.borderStyle=iif(.borderstyle=0,1,0)
endwith
*
PROCEDURE _4iu1afuxt
local m.xcolor
m.xcolor=getcolor()
if m.xcolor=-1
return .f.
endi

with _screen.activeform.container1
for i=1 to .controlcount
try
loObject=eval(".label"+trans(i))
loObject.forecolor=m.xcolor
catch
endtry
endfor
endwith

*******************************	*
PROCEDURE _4iu1afuxx    &&all backcolor
local m.xcolor
m.xcolor=getcolor()
if m.xcolor=-1
return .f.
endi

with  _screen.activeform.container1

for i=1 to .controlcount
try
loObject=eval(".label"+trans(i))
loObject.backcolor=m.xcolor
loObject.backstyle=1
catch
endtry

endfor
endwith

*
PROCEDURE _4iu1afuxz
with _screen.activeform.container1
.parent.yborder=iif(.parent.yborder=0,1,0)

if  .parent.yborder=1
.setall("borderstyle",1,"label")
else
.setall("borderstyle",0,"label")
endi
endwith

*
PROCEDURE _4iu1afuy2
with  _screen.activeform.container1
for i=1 to .controlcount
try
loObject=eval(".label"+trans(i))
loObject.forecolor=rgb(255*rand(),255*rand(),255*rand())    &&random forecolor
catch
endtry
endfor
endwith

PROCEDURE _4iu1afuy3
with  _screen.activeform.container1
for i=1 to .controlcount
try
loObject=eval(".label"+trans(i))
loObject.Backcolor=rgb(255*rand(),255*rand(),255*rand())    &&random backcolor
loObject.backStyle=1
catch
endtry
endfor
endwith

*
PROCEDURE _4iu1bv648
local m.xfontsize
m.xfontsize=int(val(inputBox("Set an unique fontsize","","12")))
with  _screen.activeform.container1
for i=1 to .controlcount
try
loObject=eval(".label"+trans(i))
loObject.fontsize=m.xfontsize
catch
endtry
endfor
endwith

endtext
strtofile(m.myvar,"yRichtext_Label.mpr")
ENDPROC

PROCEDURE edit1.Init
TEXT to this.value noshow
this code implements a basic richtextbox as a pure vfp solution.
it consists in making each word of a text in a label control and
then use the label properties to beautify the text.
It's very fast contrary to what one may think
each word can be traversed with:
.fontname
.fontsize
.fontstyle (N,B,BI,U,S)
.forecolor
.backcolor
.backstyle
.borderStyle
the label must be mandatory with autosize=.t.
Each chr(13) in original text  is repaced by " | " to preserve the line feeds.
rightclick on any element to fire the contextuel menu and then can change its properties.
after changing fontsize of any label can re Arrange the text in the contextuel menu.
all the labels are gathered in a container.Infortunatly the native one is
not scrollable (must adda new class for that...its not the goal here.)
to make the solution perfect and load a big text.
Lorem ipsum dolor sit amet, consectetur adipiscing elit.
Proin vel risus eget lorem feugiat fermentum nec a turpis.
Phasellus purus sem, mollis ac posuere eget, ornare vel orci.
Sed ac rutrum nulla. Aenean ultrices eget lectus eu efficitur.
In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non,
porta congue dolor. Aenean viverra auctor sagittis.
Integer lobortis dignissim auctor. Proin et volutpat massa.
Cras vitae felis venenatis, egestas sem quis, sodales neque.
Donec venenatis hendrerit odio, non pellentesque metus scelerisque ac.
Suspendisse aliquet rhoncus odio id viverra.
Vestibulum feugiat lectus a nisl pulvinar, in tempor metus eleifend.
Nunc id odio quam. Praesent egestas lorem ut sollicitudin consectetur.
Vestibulum id bibendum est. Ut vel lacus sapien.
Quisque eget molestie sem. Integer eget purus eu orci molestie
aliquam quis in ante. Integer a magna eget lectus finibus porttitor.
Donec fringilla sapien a quam aliquet, pellentesque blandit
nisl placerat. Nam hendrerit velit vel ex aliquam, eget convallis ante mollis.

ENDTEXT
ENDPROC


PROCEDURE command1.Click
this.enabled=.f.

local m.oo,m.rVal
m.oo=thisform.container1
m.rVal=strtran(thisform.edit1.value,chr(13)," | ")
thisform.label1.caption=trans(getwordcount (m.rVal))+" words."
with thisform.edit1
j=0
for i=1 to getwordcount (m.rVal)
oo.addobject("label"+trans(i),"label")
with eval("oo.label"+trans(i))
.caption=getwordnum(m.rVal,i)
if i=1
j=0
.left=thisform.xlmargin
.top=thisform.xtmargin
else
if allt(.caption)="|"
j=j+1
.left=thisform.xlmargin
.top= thisform.xtmargin+j*.height
.caption=""
else
.left=eval("oo.label"+trans(i-1)+".left")+eval("oo.label"+trans(i-1)+".width+thisform.xint")
.top=eval("oo.label"+trans(i-1)+".top")
endi
endi

.fontbold=.t.
.forecolor=0
.backcolor=thisform.backcolor
.borderstyle=0
.autosize=.t.
.alignment=0
.backstyle=0
.fontcharset=1
.fontname="Arial"
.fontsize=12
.rotation=0
.wordwrap=.f.
.visible=.t.
endwith
bindevent(eval("oo.label"+trans(i)),"rightclick",thisform,"my")
endfor
endwith
ENDPROC

PROCEDURE image1.Click
local m.myvar
text to m.myvar noshow
this code implements a basic richtextbox as a pure vfp solution.
it consists in making each word of a text in a label control and
then use the label properties to beautify the text.
It's very fast contrary to what one may think
each word can be traversed with:
.fontname
.fontsize
.fontstyle (N,B,BI,U,S)
.forecolor
.backcolor
.backstyle
.borderStyle
the label must be mandatory with autosize=.t.
Each chr(13) in original text  is repaced by " | " to preserve the line feeds.
rightclick on any element to fire the contextuel menu and then can change its properties.
after changing fontsize of any label can re Arrange the text in the contextuel menu.
for big fontsize must adjust the form properties xint and delta (can add a spinners on the form)
all the labels are gathered in a container.the container class from SPS solves the scroll in container to make the solution better and load a big text.
endtext
messagebox(m.myvar,0+64+4096,"Summary help")
ENDPROC

PROCEDURE DESTROY
CLEA EVENTS
ENDPROC

ENDDEFINE
*
*-- EndDefine: yRichText