An autosize VFP editbox
![]()
this code builds an autosize editbox embed in a container class. it calculates the number of lines of the editbox for any given width and then it sets the real height with a fontname,fontsize and a fontstyle as parameters. the height of an editbox line is done with fontmetric(with 1 as parameter). can resize the editbox manually with a small circular shape (positioned at the right corner). if the editbox have a very small width this fires an infinite unwanted loop ! a bindevent prevents this behavior and reset the width to a subsequent good value. the editbox scrollbars=0 and dont appear at all because the editbox autosizes itself. made a limit to the editbox area (with the properties on width (wmin) and max height(hmax)) for pratical use. each time create a new line or delete one the editbox resizes automatically.the fontmetric is used to calculate the line height to mutiply by the number of lines calculated). can select fontname,fontsize,style , backcolor,forecolor,and edition menu in contexuel editbox menu(rightclick)-can also set any property (margin..) the GetvisibleLines function is from https://www.foxite.com/archives/problem-solved-0000049585.htm from Sergey Karimov (calculates the number of lines of an editbox) [post 265]
Click on code to select [then copy] -click outside to deselect
*1* created on sunday 04 of march 2018
*an autosize editbox embed in a container class
Publi oform
oform=Newobject("yedlines")
oform.Show
Retu
*
Define Class yedlines As Form
Top = 0
Left = 0
Height = 600
Width =800
ShowWindow=2
AutoCenter=.T.
Caption = "Autosize editbox"
Name = "Form1"
Add Object ycnt As ycnt With ;
left=40,;
top=5,;
width=300,;
height=400,;
name="ycnt"
Add Object yhelp As Label With ;
anchor=768,;
left=800-30,;
top=10,;
autosize=.T.,;
caption="?",;
forecolor=Rgb(128,0,64),;
fontsize=24,;
mousepointer=15
Procedure Init
This.Resize
Endproc
Procedure yfont()
Local m.xfont
m.xfont=Getfont(thisform.ycnt.edit1.fontname,thisform.ycnt.edit1.fontsize)
If Empty(m.xfont)
Return .F.
Endi
Local m.xfontname,m.xfontsize,m.xstyle
m.xfontname=Getwordnum(m.xfont,1,',')
m.xfontsize=Int(Val(Getwordnum(m.xfont,2,',')))
m.xstyle=Getwordnum(m.xfont,3,",")
With Thisform.ycnt.edit1
.FontName=m.xfontname
.FontSize=m.xfontsize
If "B" $ m.xstyle
.FontBold=.T.
Endi
If "I" $ m.xstyle
.FontItalic=.T.
Endi
if "O" $ m.xstyle
.FontOutline= .t.
endi
if "S" $ m.xstyle
.FontShadow=.t.
endi
if "-" $ m.xstyle
.FontStrikethru=.t.
endi
if "U" $ m.xstyle
.FontUnderline=.t.
endi
.Refresh
Endwith
Endproc
Procedure yhelp.Click
Local m.myvar
TEXT to m.myvar pretext 7 noshow
*1* created on sunday 04 of march 2018
this code builds an autosize editbox embed in a container class.
it calculates the number of lines of the editbox for any given width and then it sets the real height with a fontname,fontsize and a fontstyle as parameters.
the height of an editbox line is done with fontmetric(with 1 as parameter).
can resize the editbox manually with a small circular shape (positioned at the right corner).
if the editbox have a very small width this fires an infinite unwanted loop ! a bindevent prevents this behavior and reset the width to a subsequent good value.
the editbox scrollbars=0 and dont appear at all because the editbox autosizes itself.
made a limit to the editbox area (with the properties on width (wmin) and max height(hmax)) for pratical use.
each time create a new line or delete one the editbox resizes automatically.the fontmetric is used to calculate the line height to mutiply by the number of lines calculated).
can select fontname,fontsize,style , backcolor,forecolor,and edition menu in contexuel editbox menu(rightclick)-can also set any property (margin..)
the GetvisibleLines function is from https://www.foxite.com/archives/problem-solved-0000049585.htm from Sergey Karimov (calculates the number of lines of an editbox)
ENDTEXT
Local oshell
oshell = Createobject('WScript.Shell')
oshell.Popup(m.myvar,0, 'Summary help', 0+32+4096) &&4,16,48,64...
oshell=Null
Endproc
Procedure Resize
Thisform.ycnt.Resize
Endproc
Enddefine
*
Define Class ycnt As Container
Top = 24
Left = 10
Width = 457
Height = 410
BorderWidth = 0
Name = "ycnt"
ocap=.F.
hMax=600
Wmin=200
oprop=.F.
Add Object edit1 As EditBox With ;
Anchor = 0, ;
Height = 397, ;
Left = 0, ;
Top = 1, ;
Width = 450, ;
margin=10,;
scrollbars=0 ,;
Name = "Edit1"
Add Object command1 As CommandButton With ;
Anchor=768,;
Top = 398+20, ;
Left = -150, ;
Height = 27, ;
Width = 85, ;
Anchor = 768, ;
Caption = "", ;
Style = 1, ;
Name = "Command1"
Add Object shp As Shape With ;
left=457-12,;
top =397/2,;
width=12,;
height=12,;
curvature=99,;
mousepointer=15,;
backstyle=1,;
bordercolor=255,;
backcolor=0,;
name="shp"
Add Object timer1 As Timer With ;
interval=1000,;
enabled=.F.
*!*
*
Procedure edit1.Init
TEXT to this.value pretext 7 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
*end
ENDTEXT
Endproc
Procedure Init
With This
.edit1.Left=10
.edit1.Top=10
.Width=This.edit1.Width+2*10
.Height=This.edit1.Top+This.edit1.Height+10
With .shp
.Left=.Parent.Width-.Width
.Top=0
Endwith
Bindevent(This.shp,"mousedown",This,"my")
Bindevent(This.shp,"mouseup",This,"my1")
Bindevent(This.shp,"mouseEnter",This,"my2")
Bindevent(This.shp,"mouseLeave",This,"my3")
Bindevent(This.edit1,"width",This,"aw") &&to control the editbox width (missbehavior if very small editbox width...this prevent infinite loop)
.edit1.InteractiveChange()
Endwith
Endproc
Procedure aw
If This.Width<=This.Wmin
This.Parent.timer1.Enabled=.T.
This.Parent.timer1.Timer()
Endwith
Endi
Endproc
Procedure my2
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
This.BackStyle=1
This.BackColor=Rgb(212,210,208)
Endproc
Procedure my3
Lparameters nButton, nShift, nXCoord, nYCoord
This.BackStyle=0
Endproc
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
If nButton=1
loObject.Parent.ocap=.T.
Endi
Endproc
Procedure my1 &&mouseup
Lparameters nButton, nShift, nXCoord, nYCoord
DoDefault()
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
If ! This.ocap=.T. Or nButton#1
Retur .F.
Endi
If This.Width<=This.Wmin
Nodefault
This.Width=2*This.Wmin
This.edit1.Width=This.Width-2*10
This.Refresh
This.oprop=.T. &&dont resize editbox
Endi
This.timer1.Enabled=.T.
Try
If This.oprop=.F.
This.Width=(nXCoord-This.Left)
This.edit1.Width=This.Width-20
Endi
Catch
Endtry
This.MousePointer=0
If This.oprop=.F.
This.command1.Click
Else
This.oprop=.F.
Endi
This.ocap=.F.
With This
With .shp
.Left=.Parent.Width-.Width
.Top=0
Endwith
Endwith
Endproc
Procedure timer1.Timer
Nodefault
With This.Parent
If .Width<=.Wmin
.Width=2*.Wmin
.edit1.Width=.Width-2*10
With .shp
.Left=.Parent.Width-.Width
.Top=0
Endwith
.command1.Click()
Endi
Endwith
This.Enabled=.F.
Endproc
Procedure edit1.InteractiveChange
This.command1.Click()
Endproc
Procedure command1.Click
DoDefault()
x=GetVisibleLines(This.Parent.edit1)
With This.Parent.edit1
Local m.lcStyle
m.lcStyle=""
If .FontBold=.T.
m.lcStyle=m.lcStyle+"B"
Endi
If .FontItalic
m.lcStyle=m.lcStyle+"I"
Endi
Endwith
N=Fontmetric(1, This.Parent.edit1.FontName, This.Parent.edit1.FontSize, m.lcStyle)
This.Parent.edit1.Height=N*(x+2) && added 2 lines
This.Top=This.Parent.edit1.Top+This.Parent.edit1.Height+10
This.Parent.edit1.Top=10
This.Parent.edit1.Left=10
This.Parent.Height=This.Parent.edit1.Top+This.Parent.edit1.Height+10 &&ycnt
This.Parent.Refresh
Endproc
Procedure edit1.InteractiveChange
This.Parent.command1.Click
Endproc
Procedure Resize
DoDefault()
This.command1.Click
Endproc
Procedure edit1.RightClick
Set Color Of Scheme 1 To N+/w*,GR+/N*,,,,w+/R
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() Color Scheme 1
Define Bar _Med_slcta Of raccourci Prompt "Sélectionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
PICTRES _Med_slcta ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Define Bar _Med_paste Of raccourci Prompt "Coller" ;
KEY CTRL+V, "Ctrl+V" ;
PICTRES _Med_paste ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_copy Of raccourci Prompt "Copier" ;
KEY CTRL+C, "Ctrl+C" ;
PICTRES _Med_copy ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_cut Of raccourci Prompt "Couper" ;
KEY CTRL+x, "Ctrl+X" ;
PICTRES _Med_cut ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_redo Of raccourci Prompt "Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
PICTRES _Med_redo
Define Bar _Med_undo Of raccourci Prompt "Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
PICTRES _Med_undo ;
MESSAGE "Annule la dernière modification"
Define Bar 1 Of raccourci Prompt "fontname/fontsize/style "
Define Bar 2 Of raccourci Prompt "backcolor"
Define Bar 3 Of raccourci Prompt "Forecolor"
On Selection Bar 1 Of raccourci _Screen.ActiveForm.yfont()
On Selection Bar 2 Of raccourci _Screen.ActiveForm.ycnt.edit1.BackColor=Getcolor()
On Selection Bar 3 Of raccourci _Screen.ActiveForm.ycnt.edit1.ForeColor=Getcolor()
Activate Popup raccourci
Endproc
Enddefine
*
*-- EndDefine: yedt
*==================================
Function GetVisibleLines(oObj, asLines)
* oObj - Editbox reference
* returns: number of visible lines
* asLines - array filled with lines as you see them in an Editbox
* asLines is optional parameter
Local f0, i, i0, i1, sValue, nSolidLines, nWidth, nLines, sLines[1]
f0= Type("asLines[1]")#"U" &&flag to fill asLines
With oObj
If .Value==""
Return 0
Endif
nWidth= .Width- 2*(.Margin+Iif(.BorderStyle=0,0,2));
-Iif(.ScrollBars=2,22,2) &&string width in Editbox
nSolidLines= Alines(sLines,.Value) &&sLines is array filled with solid lines
nLines= 0
For i=1 To nSolidLines
sValue= sLines[i]
Do While .T.
nLines= nLines+1
i0= GetMaxPosition(oObj, sValue, nWidth)
i1= 0
Do Case
Case i0=Len(sValue) &&Ok
Case Substr(sValue,i0+1,1)=" " &&substring is followed by " "
i1= i0+2
Do While i1<=Len(sValue) .And. Substr(sValue,i1,1)=" "
i1= i1+1 &&take all blanks to this line
Enddo
i0= i1-1
i1= -1 &&flag we have invisible tail blanks
Otherwise &&next portion starts with non blank symbol
i1= Rat(" ",Left(sValue,i0)) &&find right outmost " "
i0= Iif(i1=0,i0,i1) &&if found, break line on " "
Endcase
If f0
Dimension asLines[nLines]
asLines[nLines]= Left(sValue,i0)
Endif
Do Case
Case i0#Len(sValue) &&process next portion
sValue= Substr(sValue,i0+1)
Case i1=-1 &&in Editbox we see additional blank line
sValue= ""
Otherwise
Exit
Endcase
Enddo
Endfor
Endwith
Return nLines
Endfunc
*==================================
Function GetFontStyle(oObj) &&FontStyle string for fontmetric procedure
Local sStyle
sStyle= ""
With oObj
If Type(".FontBold")="L"
sStyle= sStyle+Iif(.FontBold, "B","")
sStyle= sStyle+Iif(.FontItalic, "I","")
sStyle= sStyle+Iif(.FontOutline, "O","")
sStyle= sStyle+Iif(.FontShadow, "S","")
sStyle= sStyle+Iif(.FontStrikethru,"-","")
sStyle= sStyle+Iif(.FontUnderline, "U","")
Endif
Endwith
Return sStyle
Endfunc
*==================================
Function GetMaxPosition(oObj, sValue, nWidth)
* returns i1 where left(sValue,i1) - maximum substring that fits nWidth
#Define TM_AVECHARWIDTH 6
Local i0, nWidth0, i1, nWidth1, i2, nWidth2, sFontStyle, nSize
With oObj
sFontStyle= GetFontStyle(oObj)
nSize= Fontmetric(TM_AVECHARWIDTH, .FontName, .FontSize, sFontStyle) &&average symbol width in pixels
i2= Len(sValue)
nWidth2= Txtwidth(sValue, .FontName, .FontSize, sFontStyle)*nSize &&line width
If nWidth2<=nWidth
Return i2
Endif
i1= 0
nWidth1= 0
Do While i2-i1>1
i0= i1+Int((nWidth-nWidth1)/(nWidth2-nWidth1)*(i2-i1)) &&linear approach
i0= Iif(i0<=i1, i1+1,;
IIF(i0>=i2, i2-1,;
i0)) &&correction, because function is not linear
If i0-i1>i2-i0 &&right substring is shorter then left one
nWidth0= nWidth2-nSize*Txtwidth(Substr(sValue,i0+1,i2-i0),;
.FontName, .FontSize, sFontStyle) &&line width to i0
Else &&left substring is shorter then right one
nWidth0= nWidth1+nSize*Txtwidth(Substr(sValue,i1+1,i0-i1),;
.FontName, .FontSize, sFontStyle) &&line width to i0
Endif
Do Case
Case nWidth0<nWidth
i1= i0
nWidth1= nWidth0
Case nWidth0>nWidth
i2= i0
nWidth2= nWidth0
Otherwise &&nWidth0=nWidth
i1= i0
Exit
Endcase
Enddo
Endwith
Return i1
Endfunc
*
Click on code to select [then copy] -click outside to deselect
*2* created on monday 05 of march 2018
*another method to make any editbox autosize using tge DrawText API.
*The DrawText function draws formatted text in the specified rectangle. It formats the text according to the specified method (expanding tabs, justifying characters, breaking lines, and so forth).
*can see it in my previous posts (see the ref below).there is also example in http://www.news2news.com/vfp/?example=303&function=469
*method adapted from http://forum.foxclub.ru/read.php?29,352767,353079#msg-353079
Public oform
oform=Newobject("yautosize_editbox")
oform.Show
Read Events
Return
*
Define Class yautosize_editbox As Form
BorderStyle = 3
Height = 435
Width = 593
ShowWindow = 2
ScrollBars = 2 &&appears if needed when the form.height grows
AutoCenter = .T.
Caption = "An autosize ditbox---Resize form to change height for autosize editbox"
ocap = .F.
Name = "Form1"
Add Object edit1 As EditBox With ;
Anchor = 10, ;
Height = 23, ;
Left = 27, ;
ScrollBars = 0, ;
Top = 15, ;
Width = 453, ;
IntegralHeight = .T., ;
Name = "Edit1"
Add Object shape1 As Shape With ;
Top = 1, ;
Left = 465, ;
Height = 12, ;
Width = 12, ;
Curvature = 99, ;
MousePointer = 15, ;
BackColor = Rgb(0,0,0), ;
BorderColor = Rgb(255,0,0), ;
Name = "Shape1"
Procedure yfont
Local m.xfont
m.xfont=Getfont(Thisform.edit1.FontName,Thisform.edit1.FontSize)
If Empty(m.xfont)
Return .F.
Endi
Local m.xfontname,m.xfontsize,m.xstyle
m.xfontname=Getwordnum(m.xfont,1,',')
m.xfontsize=Int(Val(Getwordnum(m.xfont,2,',')))
m.xstyle=Getwordnum(m.xfont,3,",")
With Thisform.edit1
.FontName=m.xfontname
.FontSize=m.xfontsize
If "B" $ m.xstyle
.FontBold=.T.
Endi
If "I" $ m.xstyle
.FontItalic=.T.
Endi
If "O" $ m.xstyle
.FontOutline= .T.
Endi
If "S" $ m.xstyle
.FontShadow=.T.
Endi
If "-" $ m.xstyle
.FontStrikethru=.T.
Endi
If "U" $ m.xstyle
.FontUnderline=.T.
Endi
.Refresh
.InteractiveChange()
Endwith
Endproc
Procedure my
Thisform.edit1.InteractiveChange()
Endproc
Procedure Load
Declare Long GetDC In "User32" ;
Long HWnd
Declare Long ReleaseDC In "User32" ;
Long nhWnd, Long hDC
Declare Long SelectObject In "Gdi32" ;
Long hDC, Long hObject
Declare Long DeleteObject In "Gdi32" ;
Long hObject
Declare Long CreateFont In "Gdi32" ;
Long nHeight, Long nWidth, Long nEscapement, Long nOrientation, Long fnWeight, ;
Long fdwItalic, Long fdwUnderline, Long fdwStrikeOut, Long fdwCharSet, ;
Long fdwOutputPrecision, Long fdwClipPrecision, Long fdwQuality, ;
Long fdwPitchAndFamily, String lpszFace
Declare Integer DrawText In user32 ;
INTEGER hDC, ; && handle to device context
String lpString, ; && pointer to string to draw
Integer nCount, ; && string length, in characters
String @lpRect, ; && pointer to struct with formatting dimensions
Integer uFormat && text-drawing flags
Declare Long GetDeviceCaps In "Gdi32" ;
Long hdc, Long nIndex
Endproc
Procedure Destroy
Clea Dlls
Clea Events
Endproc
Procedure Resize
This.edit1.InteractiveChange
Endproc
Procedure edit1.ProgrammaticChange
This.InteractiveChange()
Endproc
Procedure edit1.InteractiveChange
#Define DT_TOP 0x00
#Define DT_LEFT 0x00
#Define DT_CENTER 0x01
#Define DT_RIGHT 0x02
#Define DT_VCENTER 0x04
#Define DT_BOTTOM 0x08
#Define DT_WORDBREAK 0x10
#Define DT_SINGLELINE 0x20
#Define DT_EXPANDTABS 0x40
#Define DT_TABSTOP 0x80
#Define DT_NOCLIP 0x0100
#Define DT_EXTERNALLEADING 0x0200
#Define DT_CALCRECT 0x0400
#Define DT_NOPREFIX 0x0800
#Define DT_INTERNAL 0x1000
#Define DT_EDITCONTROL 0x00002000
#Define DT_PATH_ELLIPSIS 0x00004000
#Define DT_END_ELLIPSIS 0x00008000
#Define DT_MODIFYSTRING 0x00010000
#Define DT_RTLREADING 0x00020000
#Define DT_WORD_ELLIPSIS 0x00040000
#Define DT_NOFULLWIDTHCHARBREAK 0x00080000
#Define DT_HIDEPREFIX 0x00100000
#Define DT_PREFIXONLY 0x00200000
#Define HORZSIZE 4
#Define VERTSIZE 6
#Define HORZRES 8
#Define VERTRES 10
#Define LOGPIXELSX 88
#Define LOGPIXELSY 90
m.lhMemDC = GetDC(Thisform.HWnd)
lnScroll = Iif(This.ScrollBars= 2,Sysmetric(5)+2,0)
lnBorders = (This.Margin + 1 + Iif(This.BorderStyle= 1,1,0))*2
lsTextRect = BinToC(0,"4rs") + BinToC(0, "4rs") + BinToC(This.Width - lnScroll - lnBorders - Fontmetric(7,This.FontName,This.FontSize), "4rs") + BinToC(0, "4rs")
*-- Font
lnFontSize = -Round(This.FontSize * GetDeviceCaps(m.lhMemDC, LOGPIXELSX) / 72,0)
lhFont = CreateFont ;
(m.lnFontSize, ;
0, ;
0, ;
0, ;
Iif(This.FontBold, 700, 0), ;
Iif(This.FontItalic, 1, 0), ;
Iif(This.FontUnderline, 1, 0), ;
Iif(This.FontStrikethru, 1, 0), ;
1, ;
0, ;
0, ;
0, ;
0, ;
This.FontName)
lhOldFont = SelectObject(m.lhMemDC, m.lhFont)
*DrawStyle
lnAlign = DT_WORDBREAK
Do Case
Case This.Alignment=0
*-- left
lnAlign = m.lnAlign + DT_LEFT
Case This.Alignment=1
*-- right
lnAlign = m.lnAlign + DT_RIGHT
Case This.Alignment=2
*-- center
lnAlign = m.lnAlign + DT_CENTER
Endcase
m.lsFontRect = m.lsTextRect
DrawText(m.lhMemDC,This.Value ,Len(This.Value),@m.lsFontRect, lnAlign+DT_CALCRECT)
This.Height = Max(lnBorders+CToBin(Substr(lsFontRect, 13, 4),"4RS"),25)
SelectObject(m.lhMemDC,lhOldFont)
DeleteObject(m.lhFont)
ReleaseDC(Thisform.HWnd,m.lhMemDC)
Thisform.edit1.Top=15
Thisform.edit1.Refresh
Thisform.Height=This.Top+This.Height+10 &&10px added
With Thisform.shape1
.Width=12
.Height=12
.MousePointer=15
.Left=Thisform.edit1.Left+Thisform.edit1.Width -.Width
.Top=Thisform.edit1.Top -.Height
Endwith
Endproc
Procedure edit1.Init
TEXT to this.Value pretext 7 noshow
TEXT to this.value pretext 7 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
*end
ENDTEXT
This.Top=15
This.InteractiveChange()
Endproc
Procedure edit1.RightClick
Set Color Of Scheme 1 To N+/w*,GR+/N*,,,,w+/R
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol() Color Scheme 1
Define Bar _Med_slcta Of raccourci Prompt "Sélectionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
PICTRES _Med_slcta ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Define Bar _Med_paste Of raccourci Prompt "Coller" ;
KEY CTRL+V, "Ctrl+V" ;
PICTRES _Med_paste ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_copy Of raccourci Prompt "Copier" ;
KEY CTRL+C, "Ctrl+C" ;
PICTRES _Med_copy ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_cut Of raccourci Prompt "Couper" ;
KEY CTRL+x, "Ctrl+X" ;
PICTRES _Med_cut ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_redo Of raccourci Prompt "Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
PICTRES _Med_redo
Define Bar _Med_undo Of raccourci Prompt "Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
PICTRES _Med_undo ;
MESSAGE "Annule la dernière modification"
Define Bar 1 Of raccourci Prompt "fontname/fontsize/style "
Define Bar 2 Of raccourci Prompt "backcolor"
Define Bar 3 Of raccourci Prompt "Forecolor"
On Selection Bar 1 Of raccourci _Screen.ActiveForm.yfont()
On Selection Bar 2 Of raccourci _Screen.ActiveForm.edit1.BackColor=Getcolor()
On Selection Bar 3 Of raccourci _Screen.ActiveForm.edit1.ForeColor=Getcolor()
Activate Popup raccourci
This.InteractiveChange()
Endproc
Procedure shape1.MouseUp
Lparameters nButton, nShift, nXCoord, nYCoord
If nButton=1 And Thisform.ocap=.T.
Thisform.ocap=.F.
Try
*thisform.edit1.width=nxcoord-thisform.edit1.left
Thisform.Width=Thisform.Width+nXCoord-Thisform.edit1.Left-Thisform.edit1.Width &&interact with the form width and subsequent form.height
Thisform.edit1.Top=nYCoord
Thisform.edit1.InteractiveChange()
Catch
Endtry
Endi
Endproc
Procedure shape1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
Thisform.ocap=.T.
Endproc
Enddefine
*
*-- EndDefine: yautosize_editbox
some relative links in this blog
resize-containers-or-forms-with-gripper-classoledragdrop-with-treeview-textbox-listbox-from-windows-explorer
search-for-text-in-editbox-with-6-methods
scrolling-containers-with-pure-and-simple-vfp-solutions
the-drawtext-api-by-a-real-example
a-custom-messagebox-with-drawtext-api
a-custom-vfp-ansi-and-unicode-tooltip
Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1709(fall creator) & IE11 emulation. Navigator: firefox - screen:32 pouces.