Working with fonts
Below 17 codes on the fonts subjects, viewing, installing,printing,....and other resources.
D text
*1*
*This code lists all fonts on system
*Begin code
=AFONT(gaFontArray) && Array containS font names.
gnNumFonts = ALEN(gaFontArray) && Number of fonts
crea cursor ycurs (xfontname c(30), test c(100))
FOR nCount = 1 TO gnNumFonts
insert into ycurs values ( ALLTRIM(gaFontArray(nCount)) ,' Hello World with ' + ALLTRIM(gaFontArray(nCount)) )
ENDFOR
*brow
Browse Name ybrow Title "System fonts: "+Trans(Reccount()) Nowait &&window as oop object
With ybrow
.DeleteMark=.F.
.GridLines=0
.RecordMark=.F.
.Width=300
.Left=100
.rowHeight=24
with .column2
.sparse=.f.
endwith
.column2.DynamicFontname="allt(ycurs.xfontname)"
.column2.DynamicFontSize='12'
.column2.DynamicFontBold='.t.'
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(190,235,200))", "Column")
.refresh
locate
Endwith
*END CODE
*2*
*this is a font viewer with some utilities as searching font in list, html report, a menu on top level *form...
*Begin code
publi m.yrep
m.yrep=addbs(justpath(sys(16,1)))
local m.myvar
text to m.myvar noshow
Lparameters oFormRef, getMenuName, lUniquePopups, parm4, parm5, parm6, parm7, parm8, parm9
Local cMenuName, nTotPops, a_menupops, cTypeParm2, cSaveFormName
If Type("m.oFormRef") # "O" Or ;
LOWER(m.oFormRef.BaseClass) # 'form' Or ;
m.oFormRef.ShowWindow # 2
Messagebox([This menu can only be called from a Top-Level form. Ensure that your form's ShowWindow property is set to 2. Read the header section of the menu's MPR file for more details.])
Return
Endif
m.cTypeParm2 = Type("m.getMenuName")
m.cMenuName = Sys(2015)
m.cSaveFormName = m.oFormRef.Name
If m.cTypeParm2 = "C" Or (m.cTypeParm2 = "L" And m.getMenuName)
m.oFormRef.Name = m.cMenuName
Endif
If m.cTypeParm2 = "C" And !Empty(m.getMenuName)
m.cMenuName = m.getMenuName
Endif
Dimension a_menupops[1]
If Type("m.lUniquePopups")="L" And m.lUniquePopups
For nTotPops = 1 To Alen(a_menupops)
a_menupops[m.nTotPops]= Sys(2015)
Endfor
Else
a_menupops[1]="options"
Endif
*
Define Menu (m.cMenuName) In (m.oFormRef.Name) Bar
Define Pad _4bb132ffn Of (m.cMenuName) Prompt "Options" Color Scheme 3 ;
KEY Alt+O, ""
Define Pad _4bb132ffo Of (m.cMenuName) Prompt "Show Grid lines" Color Scheme 3 ;
KEY Alt+S, ""
Define Pad _4bb132ffp Of (m.cMenuName) Prompt "find" Color Scheme 3 ;
KEY Alt+F, ""
Define Pad _4bb132ffq Of (m.cMenuName) Prompt "Refresh" Color Scheme 3 ;
KEY Alt+R, ""
Define Pad _4bb132ffr Of (m.cMenuName) Prompt "HTML Report" Color Scheme 3 ;
KEY Alt+H, ""
Define Pad _4bb132ffs Of (m.cMenuName) Prompt "Help" Color Scheme 3 ;
KEY Alt+H, ""
On Pad _4bb132ffn Of (m.cMenuName) Activate Popup (a_menupops[1])
On Selection Pad _4bb132ffo Of (m.cMenuName) ;
DO _4bb132fft ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Pad _4bb132ffp Of (m.cMenuName) ;
DO _4bb132fg2 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Pad _4bb132ffq Of (m.cMenuName) ;
DO _4bb132fg3 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Pad _4bb132ffr Of (m.cMenuName) ;
DO _4bb132fg4 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Pad _4bb132ffs Of (m.cMenuName) ;
DO _4bb132fg5 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
Define Popup (a_menupops[1]) Margin Relative Shadow Color Scheme 4
Define Bar 1 Of (a_menupops[1]) Prompt "Bold"
Define Bar 2 Of (a_menupops[1]) Prompt "Italic"
Define Bar 3 Of (a_menupops[1]) Prompt "Underline"
Define Bar 4 Of (a_menupops[1]) Prompt "Stroke"
On Selection Bar 1 Of (a_menupops[1]) ;
DO _4bb132fg6 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Bar 2 Of (a_menupops[1]) ;
DO _4bb132fg7 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Bar 3 Of (a_menupops[1]) ;
DO _4bb132fg8 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
On Selection Bar 4 Of (a_menupops[1]) ;
DO _4bb132fg9 ;
IN Locfile("TOPOST\YMENU" ,"MPX;MPR|FXP;PRG" ,"WHERE is YMENU?")
Activate Menu (m.cMenuName) Nowait
If m.cTypeParm2 = "C"
m.getMenuName = m.cMenuName
m.oFormRef.Name = m.cSaveFormName
Endif
*
Procedure _4bb132fft
With _Screen.ActiveForm.grid1
Try
.GridLines=.GridLines +1
Catch
.GridLines=0
Endtry
Endwith
*
Procedure _4bb132fg2
*=SYS(1500, '_MED_FIND','_MEDIT' )
Local Y
Y=Inputbox("Type,the font to find here","","Arial")
Sele ycurs
Locate For Lower(Allt(Y)) $ Lower(Allt(yfontname))
_Screen.ActiveForm.grid1.SetFocus
*
Procedure _4bb132fg3
Sele ycurs
_Screen.ActiveForm.grid1.Refresh
*
Procedure _4bb132fg4
_SCREEN.ACTIVEFORM.Yhtml()
*
Procedure _4bb132fg5
_screen.activeform.yhelp()
*
Procedure _4bb132fg6
_Screen.ActiveForm.ybold=! _Screen.ActiveForm.ybold
With _Screen.ActiveForm.grid1
For i=1 To .ColumnCount
.Columns(i).DynamicFontBold ="(_screen.activeform.ybold)"
Endfor
.Refresh
Endwith
*
Procedure _4bb132fg7
_Screen.ActiveForm.yItalic=! _Screen.ActiveForm.yItalic
With _Screen.ActiveForm.grid1
For i=1 To .ColumnCount
.Columns(i).DynamicFontItalic ='(_screen.activeform.yitalic)'
Endfor
.Refresh
Endwith
*
Procedure _4bb132fg8
_Screen.ActiveForm.yUnderline=! _Screen.ActiveForm.yUnderline
With _Screen.ActiveForm.grid1
For i=1 To .ColumnCount
.Columns(i).DynamicFontUnderline ='(_screen.activeform.yunderline)'
Endfor
.Refresh
Endwith
*
Procedure _4bb132fg9
_Screen.ActiveForm.yStroke=! _Screen.ActiveForm.yStroke
With _Screen.ActiveForm.grid1
For i=1 To .ColumnCount
.Columns(i).DynamicFontStrikethru ='(_screen.activeform.yStroke)'
Endfor
.Refresh
Endwith
endtext
strtofile(m.myvar,m.yrep+"ymenu.mpr")
publi yform
yform=newObject("asup")
yform.show
read events
return
*
DEFINE CLASS asup AS form
Height = 547
Width = 948
ShowWindow = 2
AutoCenter = .T.
Caption = "System availbale fonts"
WindowType = 1
ybold = .F.
yitalic = .F.
yunderline = .F.
ystroke = .F.
firstclick = 0
Name = "Form1"
ADD OBJECT grid1 AS grid WITH ;
FontBold = .T., ;
FontSize = 14, ;
Anchor = 15, ;
DeleteMark = .F., ;
GridLines = 0, ;
Height = 552, ;
Left = 0, ;
ReadOnly = .T., ;
RecordSource = "'ycurs'", ;
RowHeight = 30, ;
ScrollBars = 3, ;
Top = 0, ;
Width = 948, ;
Name = "Grid1"
PROCEDURE my
sele ycurs
with this
if .firstClick=0
.firstclick=1
set order to yfontname descending
.grid1.column1.header1.picture="descend.bmp"
else
.firstclick=0
.grid1.column1.header1.picture="ascend.bmp"
set order to yfontname ascending
endi
.grid1.refresh
endwith
locate
ENDPROC
PROCEDURE my1
local aa
aa=getenv("windir")+"\fonts\" &&+allt(yfontname)
run/n explorer &aa
ENDPROC
PROCEDURE Init
#define AW_BLEND 0x00080000
Declare AnimateWindow In Win32API Long Thehwnd, Long TimeInMilliSeconds, Long Flags
=animatewindow(this.hwnd,3000,AW_BLEND)
do( m.yrep+'ymenu.mpr') with this,.t.
sele ycurs
this.caption=this.caption+" ("+trans(reccount())+")"
BINDEVENT(this.grid1.column1.header1,;
"click",this,"my")
this.firstClick=0
BINDEVENT(this.grid1.column1.text1,;
"rightclick",this,"my1")
ENDPROC
PROCEDURE Load
create cursor ycurs ( yfontname c(25),yfontname1 c(25), yfontname2 c(30),yfontname3 c(35))
=AFONT(gaFontArray) && Array containS font names.
gnNumFonts = ALEN(gaFontArray) && Number of fonts
FOR nCount = 1 TO gnNumFonts
insert into ycurs values(ALLTRIM(gaFontArray(nCount)),"ABCDEFGHI1234856789","ABCDEFGHI1234856789","ABCDEFGHI1234856789")
ENDFOR
*brow
sele ycurs
index on yfontname tag yfontname
set order to YFONTNAME
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE grid1.Init
sele ycurs
with this
.recordsource="ycurs"
endwith
with this
.column1.DynamicFontName = "allt(yfontname)"
.column2.DynamicFontName = "allt(yfontname)"
.column2.DynamicFontsize = "12"
.column3.DynamicFontName = "allt(yfontname)"
.column3.DynamicFontSize = "16"
.column4.DynamicFontName = "allt(yfontname)"
.column4.DynamicFontSize = "24"
.column1.header1.caption="FONTNAME"
.column1.header1.fontbold=.t.
.column2.header1.caption="FONTSIZE=12"
.column2.header1.fontbold=.t.
.column3.header1.caption="FONTSIZE=16"
.column3.header1.fontbold=.t.
.column4.header1.caption="FONTSIZE=24"
.column4.header1.fontbold=.t.
endwith
locate
ENDPROC
PROCEDURE YHELP
Local m.myvar
TEXT to m.myvar noshow
This is a small utility that enumerates all fonts installed on your system,
and displays them in one simple grid.
For each font,it draws 3 samples of the font in different sizes,
in order to allow to easily find and choose the desired font that you need.
it also allow to view the fonts as Bold, as Italic or with underline, as well
as it allows you to export the fonts list into html file.
the fontname column can be ordered ascending/descending.
A rightclick on any field fires the font as Windows view it(can also print the page).
You can search after any font installed and configure the grid lines.
ENDTEXT
Try
Set Bell To (Addbs(Getenv('windir')))+"MEDIA\NOTIFY.WAV"
?? Chr(7)
Catch
Endtry
Messagebox(m.myvar,0+32+4096,"Help")
Endproc
PROCEDURE YHTML
Set Memowidth To 8192
Sele ycurs
Local xx
xx="<tr><td><font face='Arial' size='3'>FontName</font></td> <td><font face='Arial' size='3'>Font with size=3</font></td> <td><font face='Arial' Size='3'>Font with Size=5</font></td> <td><font face='Arial' size='6'>Font With Size=6</font</td></tr>"
Scan
xx=xx+"<tr><td><font face='" +Allt(yfontname)+ "' size='2'>"+ Allt(yfontname)+"</font></td><td><font face=' "+Allt(yfontname)+"' size='3'> ABCDEFGHI123456789</font></td><td><font face=' "
xx=xx+Allt(yfontname)+"' size='5'>ABCDEFGHI123456789</font></td><td><font face='"+Allt(yfontname)+"' size='6'>ABCDEFGHI123456789</font></td></tr>"
Endscan
Locate
TEXT to m.myvar textmerge noshow
<html>
<head>
<title> <<trans(reccount())>> available fonts on system</title>
</head>
<body bgcolor=LightGoldenRodYellow oncontextmenu="javascript:return false;" >
<h2 align="center" ><font face="Arial" color=red>Available Fonts on system (<<reccount()>>)</font></h2>
<table border="1" cellspacing="6">
<<allt(m.xx)>>
</table>
</body>
</html>
ENDTEXT
Local lcfilename
Set Safe Off
lcfilename=Addbs(Sys(2023))+"ytable.html"
Strtofile(m.myvar,m.lcfilename)
Set Safe Off
Local m.oo
m.oo=Newobject("hyperlink")
m.oo.NavigateTo(m.lcfilename)
ENDPROC
ENDDEFINE
*
*-- EndDefine: asup
*Endcode
*3*
*this use acomboBox to show all fonts with a random backcolor
*its some slow.
*Begin code
Public yform
yform=Createobject("asup")
yform.Show()
Return
Define Class asup As Form
Top = 0
Left = 0
Height = 150
Width = 400
MaxButton=.F.
MinButton=.F.
BorderStyle=2
ShowWindow=2
AutoCenter=.T.
ycount=0
Caption = "Visual system fonts "
Name = "Form1"
Add Object list1 As ComboBox With ;
RowSourceType = 9, ;
RowSource = "Ymenu", ;
Height = 27, ;
Left = 10, ;
Top =10, ;
Width =300, ;
Name = "list1"
Add Object label1 As Label With ;
Height = 27, ;
top=80,;
Left =10 ,;
Width =380, ;
caption="" ,;
alignment=0,;
fontsize=16,;
Name = "label1"
Procedure Load
Publi Ymenu
=Afont(gaFontArray) && Array containS font names.
gnNumFonts = Alen(gaFontArray) && Number of fonts
Thisform.ycount=gnNumFonts
cr=Chr(13)+Chr(10)
Set Textmerge On Noshow
x=" DEFINE POPUP Ymenu "
=Execscript(m.x)
For i=1 To gnNumFonts
gnLower = 1
gnUpper = 255
R= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
g= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
b= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
R1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
g1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
b1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
x= [DEFINE BAR ]+Trans(i)+[ OF Ymenu PROMPT "]+ gaFontArray(i)+[" FONT "]+gaFontArray(i)+[",12 style "B" COLOR , RGB(]+Trans(m.R)+","+Trans(m.g)+","+Trans(m.b)+","+Trans(m.R1)+","+Trans(m.g1)+","+Trans(m.b1)+[)]
=Execscript(m.x)
Endfor
Endproc
Procedure Init
Thisform.Caption=Thisform.Caption+" - ("+Trans(Thisform.ycount)+")"
Procedure list1.Click
With Thisform.label1
.FontName=This.Value
.Caption=This.Value
Endwith
Endproc
Enddefine
*END CODE
*4*
*Another fonts viewer on form (with labels support)
*begin code
Publi ygetfont
ygetfont=Newobject("ygetfont")
ygetfont.Show
Return
*
Define Class ygetfont As Form
Height = 300
Width = 324
ShowWindow = 2
ScrollBars = 2
AutoCenter = .T.
BorderStyle = 2
Caption = "All WYSYWIG system fonts"
MaxButton = .F.
KeyPreview = .T.
AlwaysOnTop = .T.
BackColor = Rgb(223,230,145)
Name = "Form1"
Add Object shape2 As Shape With ;
Top = 1, ;
Left = 48, ;
Height = 26, ;
Width = 205, ;
BackStyle = 1, ;
BorderStyle = 0, ;
Curvature = 20, ;
BackColor = Rgb(255,0,0), ;
Name = "Shape2"
Add Object ylab0 As Label With ;
AutoSize = .T., ;
FontName = "JUSTICE", ;
FontSize = 24, ;
Alignment = 2, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Caption = "All system fonts", ;
Height = 34, ;
Left = 67, ;
Top = -3, ;
Width = 164, ;
ForeColor = Rgb(0,0,255), ;
Name = "yLAb0"
Procedure my
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
_Cliptext=loObject.Caption
Messagebox("The Fontname you have selected is : "+loObject.Caption,0+32+4096,"Copied to clipboard")
Endproc
Procedure Init
This.TitleBar=1
=Afont(gaFontArray) && Array containS font names.
gnNumFonts = Alen(gaFontArray) && Number of fonts
xtop=27
With This
.ShowTips=.T.
For i=1 To gnNumFonts
aa="label"+Trans(i)
.AddObject(m.aa,"label")
With Eval("."+aa)
.Left=15
.Width=Thisform.Width-15
.Height=24
.Top=xtop+(i-1)*(.Height)+1
.FontName=gaFontArray(i)
.FontSize=12
.Caption=.FontName
.BorderStyle=1
.Alignment=2
.AutoSize=.F.
.ToolTipText=.Caption
.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
.Visible=.T.
.MousePointer=15
Endwith
Bindevent(Eval("."+aa),"click",Thisform,"my")
Endfor
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: ygetfont
*ENDCODE
*!* get all fonts present on system in html view as WYSYWIG (what you see is what you get)
*its uses an html support to browse all fonts in a scrollable window
*5*
*Begin code
Declare Integer BringWindowToTop In user32 Integer
Declare Integer Sleep In kernel32 Integer
=Afont(gaFontArray) && Array containS font names.
gnNumFonts = Alen(gaFontArray) && Number of fonts
Local myvar,r,g,b,color1,color2,gnLower,gnUpper,r1,g1,b1
myvar=""
For j=1 To gnNumFonts
gnLower = 1
gnUpper = 255
r= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
g= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
b= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
xcolor=Color2Html(Rgb(m.r,m.g,m.b))
color1=xcolor.cHTMLcolor
r1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
g1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
b1= Int((gnUpper - gnLower + 1) * Rand( ) + gnLower)
ycolor=Color2Html(Rgb(m.r1,m.g1,m.b1))
color2=ycolor.cHTMLcolor
m.myvar=m.myvar+[<TR ><td style="cursor: hand" onclick="alert(']+gaFontArray(j)+[-copied to clipboard !') ; copyToClipboard(']+m.gaFontArray(j)+[')"; bgcolor="]+Trans(m.color2)+["><center><b><i> <font size="3" face="]+gaFontArray(j)+[" color="]+Trans(m.color1)+[" >]+ gaFontArray(j)+[ </font></i></b></center></td></tr>]
Endfor
TEXT to m.myvar textmerge noshow
<htlml>
<body>
<table border="2" bgcolor="orange">
<<m.myvar>>
</table >
</body>
</html>
ENDTEXT
Set Safe Off
Local lcfile
lcfile=Addbs(Sys(2023))+"asup.html"
=Strtofile(m.myvar,m.lcfile)
Set Safe On
Publi apie
apie=Newobject("internetexplorer.application")
With apie
.Navigate("file:///"+m.lcfile)
.Toolbar=0
.StatusBar=0
.menubar=0
.Width=330
.Height=500
.silent=.T.
.Left=(Sysmetric(1)-.Width)/2
.Resizable=0
Do While .busy readystate#4
Sleep(100)
Enddo
Inkey(1)
.Document.Title="System fonts="+Trans(m.gnNumFonts)
=BringWindowToTop(apie.HWnd)
.Visible=.T.
Endwith
Retu
* Converts color number to HTML color format
Function Color2Html
Lparameters tnColor
Local loColor
loColor = Createobject("Empty")
AddProperty(loColor, "nR", Bitand(tnColor, 0xFF))
AddProperty(loColor, "nG", Bitand(Bitrshift(tnColor, 8), 0xFF))
AddProperty(loColor, "nB", Bitand(Bitrshift(tnColor, 16), 0xFF))
AddProperty(loColor, "cHTMLcolor", Strtran("#" + ;
TRANSFORM(loColor.nR, "@0") + ;
TRANSFORM(loColor.nG, "@0") + ;
TRANSFORM(loColor.nB, "@0"), "0x000000", "" ))
Return loColor
*END CODE
*6*
*List all fonts installed and view by rightclick on any font.create also a txt file with all fonts.
*Begin Code
Publi yrep
yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
Set Deleted On
Local m.myvar
TEXT to m.myvar textmerge noshow
regedit /E <<m.yrep>>yfonts.txt "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts"
ENDTEXT
Local oshell
oshell=Newobject("wscript.shell")
oshell.Run(m.myvar,0,.T.)
oshell=Null
Local ystr,xx,xf
ystr=Substr(Strconv(Filetostr(yrep+"yfonts.txt");
,6),2)
ystr=Strtran(m.ystr,'"',"")
ystr=Strtran(m.ystr,"=",Chr(13)+Chr(10))
TEXT to m.myvar noshow
Windows Registry Editor Version 5.00
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts]
ENDTEXT
ystr=Strtran(m.ystr,m.myvar,"")
_Cliptext=m.ystr
Create Cursor ycurs (FontName c(50),demo c(40),Source c(50),Reg_Font c(40))
For i=1 To Memlines(m.ystr) Step 2 &&4è line available
xx=Allt(Mline(m.ystr,i))
xf=m.xx
*xf=strtran(m.xf,"8,10,12,14,18,24","",1)
*xf=strtran(m.xf,"Symbol 8,10,12,14,18,24","",1)
xf=Strtran(m.xf,"(TrueType)","",1)
xf=Strtran(m.xf,"(All res)","",1)
xf=Strtran(m.xf,"(toutes résolutions)","",1)
xf=Strtran(m.xf,"(VGA res)","",1)
*xf=strtran(m.xf,',','',1)
*xf=strtran(m.xf,"012345678","",1)
*xf=strextract(m.xf,"","(")
yy=Getenv("windir")+"\fonts\"+Allt(Mline(m.ystr,i+1))
Insert Into ycurs Values(m.xf,"this is a demo",m.yy,m.xx)
Endfor
&&replace incorrect font syntaxes
Repl All FontName With "Courier" For FontName="Courier 10,12,15 "
Repl All FontName With "MS Sans Serif" For FontName ="MS Sans Serif 8,10,12,14,18,24 "
Repl All FontName With "MS Serif" For FontName ="MS Serif 8,10,12,14,18,24"
Repl All FontName With "MS Dialog Light" For FontName ="MS Dialog Light 8,10"
Repl All FontName With "Symbol" For FontName ="Symbol 8,10,12,14,18,24"
Repl All FontName With "MS Sans Serif" For FontName ="MS Sans Serif 8,10,12,14,18,24"
Repl All FontName With "MS Serif" For FontName ="MS Serif 8,10,12,14,18,24"
Repl All FontName With "MS Dialog Light" For FontName ="MS Dialog Light 8,10"
Locate
Publi yform
yform=Newobject("yform")
yform.Show(1)
Define Class yform As Form
Width=900
Height=600
AutoCenter=.T.
ShowWindow=2
Caption="All installed fonts on system-rightclick to view the font in font viewer"
Name="form1"
Add Object grid1 As Grid With ;
anchor=15,;
left=0,;
top=0,;
width=900,;
height=600,;
recordsource="ycurs" ,;
recordsourcetype=1,;
readonly=.T.,;
rowheight=25,;
deletemark=.F.,;
gridlines=0,;
scrollbars=3,;
name="grid1"
Procedure Init
With Thisform.grid1.column1
.header1.FontBold=.T.
.DynamicFontBold=".t."
.DynamicForeColor="rgb(0,0,255)"
Endwith
With Thisform.grid1
.Themes=.F.
.MousePointer=15
.HeaderHeight=25
.SetAll("fontbold",.T.,"header")
.SetAll("fonsize",14,"header")
.SetAll("backcolor",0,"header")
.SetAll("forecolor",Rgb(0,255,0),"header")
.column2.header1.FontBold=.T.
.column2.DynamicFontSize="14"
.column2.DynamicFontName="allt(fontname)"
Endwith
For i=1 To 4
Bindevent(Thisform.grid1.Columns(i).text1;
,"rightclick",Thisform,"my")
Endfor
Sele ycurs
Go Botto
Dele
Locate
This.Caption=This.Caption+" - ("+Trans(Reccount()-1)+" fonts) "
Endproc
Procedure my
Try
m.xsource=Strtran(Source,"(TrueType)",".ttf")
Local m.myvar
TEXT to m.myvar textmerge noshow
<<addbs(getenv('windir'))>>System32\Fontview.exe <<m.xsource>>
ENDTEXT
Local oshell
oshell=Newobject("wscript.shell")
oshell.Run(m.myvar)
Catch
Endtry
Endproc
Enddefine
*End Code
*7*
*list some particular fonts and all fonts on form
*Begin code
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Return
*
Define Class asup As Form
BorderStyle = 2
Top = 11
Left = 227
Height = 408
Width = 511
ShowWindow = 2
ScrollBars = 2
ShowTips = .T.
Caption = "Fonts & Special visual Fonts "
MaxButton = .F.
BackColor = Rgb(207,253,176)
Name = "Form1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 12, ;
FontUnderline = .T., ;
BackStyle = 0, ;
Caption = "WindDings font", ;
Height = 22, ;
Left = 0, ;
Top = 2, ;
Width = 120, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 12, ;
FontUnderline = .T., ;
BackStyle = 0, ;
Caption = "WebDings font", ;
Height = 22, ;
Left = 137, ;
Top = 2, ;
Width = 115, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label2"
Add Object shape1 As Shape With ;
Top = -3, ;
Left = 127, ;
Height = 6000, ;
Width = 4, ;
BackColor = Rgb(128,0,64), ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 0, ;
Left = 261, ;
Height = 6000, ;
Width = 4, ;
BackColor = Rgb(128,0,64), ;
Name = "Shape2"
Add Object label3 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 12, ;
FontUnderline = .T., ;
BackStyle = 0, ;
Caption = "All styles fonts on system", ;
Height = 22, ;
Left = 285, ;
Top = 3, ;
Width = 196, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label3"
Add Object shape3 As Shape With ;
Top = 0, ;
Left = 266, ;
Height = 6000, ;
Width = 4, ;
BackColor = Rgb(128,0,64), ;
Name = "Shape3"
Add Object shape4 As Shape With ;
Top = -1, ;
Left = 132, ;
Height = 6000, ;
Width = 4, ;
BackColor = Rgb(128,0,64), ;
Name = "Shape4"
Add Object shape5 As Shape With ;
Top = 20, ;
Left = -2, ;
Height = 6, ;
Width = 542, ;
BackColor = Rgb(128,0,64), ;
Name = "Shape5"
Procedure Destroy
Clea Events
Endproc
Procedure Init
*Wingdings font
Local aa,bb
For i=34 To 254
aa="ynum"+Trans(i)
This.AddObject(m.aa,"label")
bb="znum"+Trans(i)
This.AddObject(m.bb,"label")
With Thisform.&aa
.FontName="Arial"
.FontSize=16
.Left=5
.Width=40
.Height=27
.Top=30+(i-34)*.Height
.Caption=Trans(i)
.BackColor=Rgb(0,255,255)
Endwith
With Thisform.&bb
.FontName="Wingdings"
.FontSize=16
.Left=Thisform.ynum34.Left+Thisform.ynum34.Width+1
.Width=70
.Height=27
.Top=30+(i-34)*.Height
.Caption=Chr(i)
.BackColor=Rgb(255,255,255)
Endwith
Endfor
*Webdings font
For i=34 To 254
aa="ynuma"+Trans(i)
This.AddObject(m.aa,"label")
bb="znuma"+Trans(i)
This.AddObject(m.bb,"label")
With Thisform.&aa
.FontName="Arial"
.FontSize=16
.Left=Thisform.label2.Left
.Width=40
.Height=27
.Top=30+(i-34)*.Height
.Caption=Trans(i)
.BackColor=Rgb(0,255,255)
Endwith
With Thisform.&bb
.FontName="Webdings"
.FontSize=16
.Left=Thisform.ynuma34.Left+Thisform.ynuma34.Width+1
.Width=70
.Height=27
.Top=30+(i-34)*.Height
.Caption=Chr(i)
.BackColor=Rgb(255,255,255)
Endwith
Endfor
*all font styles on system
=Afont(gaFontArray) && Array containS font names.
gnbre=Alen (gaFontArray)
For i=1 To gnbre
aa="ynumc"+Trans(i)
This.AddObject(m.aa,"label")
With Thisform.&aa
.FontName=gaFontArray(i)
.FontSize=16
.Left=Thisform.label3.Left
.Width=250
.Height=27
.Top=30+(i-1)*.Height
.Caption=" "+gaFontArray(i)
.BackColor=Rgb(255,255,0)
.ToolTipText=gaFontArray(i)
Endwith
Endfor
This.SetAll("visible",.T.)
Endproc
Enddefine
*
*-- EndDefine: asup
*Endcode
*8*
*Install any valid font on system
*Begin code
Local oshell
oShell = CreateObject("Shell.Application")
objFolder = oShell.Namespace("ssFONTS")
objFolder.CopyHere ("fullpath to Myfont.ttf")
*End code
oShell = CreateObject("Shell.Application")
objFolder = oShell.Namespace("<Folder or Share Location>")
objFolderItem = objFolder.ParseName("<TTF File Name>")
objFolderItem.InvokeVerb("Install")
*9*
*this code gathers all system files fonts in a cursor and show in grid
*Any click on a font displays it in the system viewer (can see properties,print, (install)).
*Begin code
Publi yform
yform=Newobject("yfonts")
yform.Show
Read Events
Return
*
Define Class yfonts As Form
BorderStyle = 3
Height = 403
Width = 421
ShowWindow = 2
AutoCenter = .T.
Caption = ""
MaxButton = .F.
BackColor = Rgb(191,191,255)
Name = "Form1"
Add Object grid1 As Grid With ;
Anchor = 15, ;
Height = 406, ;
Left = 45, ;
Top = 1, ;
Width = 327, ;
Name = "Grid1"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
Sele ycurs
Local m.myvar
TEXT to m.myvar textmerge noshow
<<addbs(getenv('windir'))>>System32\Fontview.exe <<addbs(getenv('windir'))>>Fonts\<<allt(xfontname)>>
ENDTEXT
*Messagebox(m.myvar)
If ! ShellExecute(0, "open", Addbs(Getenv('windir'))+"System32\Fontview.exe",Addbs(Getenv('windir'))+"Fonts\"+Allt(xfontname),"",1)>32
Messagebox("An error was occured!",16+4096,"zrror",1000)
Endi
Endproc
Procedure Init
With Thisform.grid1
.RecordSource="ycurs"
.RecordSourceType=1
.GridLines=0
.DeleteMark=.F.
.RecordMark=.F.
.FontBold=.T.
.MousePointer=15
.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(210,205,180))", "Column")
Locate
Bindevent(.column1.text1,"mousedown",Thisform,"my")
Endwith
Thisform.Caption="System Font viewer :"+Trans(Reccount())-" system fonts"
Endproc
Procedure Load
Close Data All
&&shellexecute
Declare Integer ShellExecute In SHELL32.Dll Integer nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
gnbre=Adir(gabase,Addbs(Getenv("windir"))+"fonts\*.*") && ttf,otf
Create Cursor ycurs ( xfontname c(40))
For i=1 To gnbre
If Inlist(Lower(Justext(gabase(i,1))),"ttf","otf","fon")
Insert Into ycurs Values (Spac(5)+ Allt(gabase(i,1)))
Endi
Endfor
Locate
*brow
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: yfonts
*End code
*10*
*this code use a menu to see all fonts
Afont(laFont)
Define Popup FontS
For Index = 1 To Alen(laFont)
Define Bar Index Of FontS Prompt Alltrim(laFont(Index)) Font Alltrim(laFont(Index)), 12 Style "B" Color G/W*, B/W*,,,,W+/GR
Endfor
Activate Popup FontS
Retu
*adapted from http://fox.wikis.com/wc.dll?Wiki~AnEasyWayToPreviewFonts~Wiki
*11*
* adapted from original open code from news2news
*Begin code
Do Decl
#Define GMEM_FIXED 0
#Define LF_FACESIZE 32
#Define FW_NORMAL 400
#Define DEFAULT_CHARSET 1
#Define OUT_DEFAULT_PRECIS 0
#Define CLIP_DEFAULT_PRECIS 0
#Define DEFAULT_QUALITY 0
#Define DEFAULT_PITCH 0
#Define CF_SCREENFONTS 1
#Define CF_INITTOLOGFONTSTRUCT 64
#Define CF_EFFECTS 256
#Define CF_FORCEFONTEXIST 65536
*| typedef struct {
*| DWORD lStructSize; 4
*| HWND hwndOwner; 4
*| HDC hDC; 4
*| LPLOGFONT lpLogFont; 4
*| INT iPointSize; 4
*| DWORD Flags; 4
*| COLORREF rgbColors; 4
*| LPARAM lCustData; 4
*| LPCFHOOKPROC lpfnHook; 4
*| LPCTSTR lpTemplateName; 4
*| HINSTANCE hInstance; 4
*| LPTSTR lpszStyle; 4
*| WORD nFontType; 2
*| WORD ___MISSING_ALIGNMENT__; 2
*| INT nSizeMin; 4
*| INT nSizeMax; 4
*| } CHOOSEFONT, *LPCHOOSEFONT; total: 60 bytes
*| typedef struct tagLOGFONT {
*| LONG lfHeight; 4
*| LONG lfWidth; 4
*| LONG lfEscapement; 4
*| LONG lfOrientation; 4
*| LONG lfWeight; 4
*| BYTE lfItalic; 1
*| BYTE lfUnderline; 1
*| BYTE lfStrikeOut; 1
*| BYTE lfCharSet; 1
*| BYTE lfOutPrecision; 1
*| BYTE lfClipPrecision; 1
*| BYTE lfQuality; 1
*| BYTE lfPitchAndFamily; 1
*| TCHAR lfFaceName[LF_FACESIZE]; 32
*| } LOGFONT, *PLOGFONT; total: 60 bytes
Local lcChooseFont, lcLogFont, hLogFont, lcFontFace
* initializing LOGFONT structure:
* Times New Roman, Italic
lcLogFont = num2dword(16) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(FW_NORMAL) +;
Chr(1) +;
Chr(0) +;
Chr(0) +;
Chr(DEFAULT_CHARSET) +;
Chr(OUT_DEFAULT_PRECIS) +;
Chr(CLIP_DEFAULT_PRECIS) +;
Chr(DEFAULT_QUALITY) +;
Chr(DEFAULT_PITCH) +;
PADR("Times New Roman"+Chr(0),32)
* copying the LOGFONT data into the global memory object
* because CHOOSEFONT structure uses the pointer
lnLogFontSize = 60
hLogFont = GlobalAlloc(GMEM_FIXED, lnLogFontSize)
* this function is re-declared below
* with different parameter types
Declare RtlMoveMemory In kernel32 As String2Heap;
INTEGER Destination, String @ Source,;
INTEGER nLength
= String2Heap (hLogFont, @lcLogFont, lnLogFontSize)
* initializing CHOOSEFONT structure
lcChooseFont = num2dword(60) +;
num2dword(0) +;
num2dword(0) +;
num2dword(hLogFont) +;
num2dword(0) +;
num2dword(CF_SCREENFONTS + CF_EFFECTS +;
CF_INITTOLOGFONTSTRUCT + CF_FORCEFONTEXIST) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0) +;
num2dword(0)
If ChooseFont (@lcChooseFont) <> 0
* displaying selection
* re-declaring API function with different parameters
Declare RtlMoveMemory In kernel32 As Heap2String;
STRING @Dest, Integer Source, Integer nLength
* copying data from the global memory object to VFP string
= Heap2String (@lcLogFont, hLogFont, lnLogFontSize)
m.x=Substr(lcLogFont, 29)
m.x=Substr(m.x, 1, At(Chr(0),m.x)-1 )
TEXT to m.myvar textmerge noshow
Font Face: << m.x>>
"*** CHOOSEFONT Structure:"
lStructSize:<< buf2dword(SUBSTR(lcChooseFont, 1,4))>>
HwndOwner:<< buf2dword(SUBSTR(lcChooseFont, 5,4))>>
lpLogFont:<< buf2dword(SUBSTR(lcChooseFont, 9,4))>>
Point size:<< buf2dword(SUBSTR(lcChooseFont, 17,4))>>
RGB color: << buf2dword(SUBSTR(lcChooseFont, 25,4))>>-or-<<rgb2string( buf2dword(SUBSTR(lcChooseFont, 25,4)))>>
"*** LOGFONT Structure:"
Font Weight:<< buf2dword(SUBSTR(lcLogFont, 17,4))>>
Italic: << Iif(Asc(SUBSTR(lcLogFont, 21,1))=0, "No","Yes")>>
Underline: << Iif(Asc(SUBSTR(lcLogFont, 22,1))=0, "No","Yes")>>
Strikeout: << Iif(Asc(SUBSTR(lcLogFont, 23,1))=0, "No","Yes")>>
ENDTEXT
*"Script: ",<< buf2dword( SUBSTR(lcLogFont, 1,60))>>
Messagebox(m.myvar,0+32+4096,m.x)
Endif
* releasing system resources
= GlobalFree (hLogFont)
Return
Procedure Decl
Declare Integer ChooseFont In comdlg32 String @lpcf
Declare Integer GlobalFree In kernel32 Integer Hmem
Declare Integer GlobalAlloc In kernel32;
INTEGER wFlags,;
INTEGER dwBytes
Function num2dword (lnValue)
#Define m0 256
#Define m1 65536
#Define m2 16777216
Local b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3*m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
Function buf2dword (lcBuffer)
Return Asc(Substr(lcBuffer, 1,1)) + ;
Asc(Substr(lcBuffer, 2,1)) * 256 +;
Asc(Substr(lcBuffer, 3,1)) * 65536 +;
Asc(Substr(lcBuffer, 4,1)) * 16777216
Function rgb2string
Lparameters xcolor
Local RGBChr,red,green,blue
m.RGBChr=Left(BinToC(xcolor,'R'),3)
red=Asc(Substr(m.RGBChr,1,1)) && RED
green=Asc(Substr(m.RGBChr,2,1)) && GREEN
blue=Asc(Substr(m.RGBChr,3,1)) && BLUE
Return 'rgb('+Trans(red)+","+Trans(green)+","+Trans(blue)+')'
*End code
*12*
* Createfont Api defines a font with all recquired parameters based on usual fontname.
*Textout Api print a text on any window (having a windows handle as a vfp form).
*Begin code
Publi yform
yform=Newobject("yfonts")
yform.Show(1)
Return
*
Define Class yfonts As Form
Height = 501
Width = 866
WindowType=1
Movable=.F.
MaxButton=.F.
MinButton=.F.
AutoCenter = .T.
Caption = "APIs and fonts"
Name = "Form1"
Add Object timer1 As Timer With ;
interval=500,;
enabled=.T.,;
name="timer1"
Procedure _print
Lparameters HWnd,x,Y,Size,lcText, lnColor, lnAngle,xFont
#Define TRANSPARENT 1
#Define OPAQUE 2
#Define ANSI_CHARSET 0
#Define OUT_DEFAULT_PRECIS 0
#Define OUT_DEVICE_PRECIS 5
#Define OUT_OUTLINE_PRECIS 8
#Define CLIP_DEFAULT_PRECIS 0
#Define CLIP_STROKE_PRECIS 2
#Define DEFAULT_QUALITY 0
#Define PROOF_QUALITY 2
#Define DEFAULT_PITCH 0
#Define FW_BOLD 700
hFont = CreateFont (;
size,0, lnAngle,lnAngle, FW_BOLD, 0,0,0, ANSI_CHARSET,;
OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
PROOF_QUALITY, DEFAULT_PITCH, xFont)
hdc = GetWindowDC (HWnd)
* select new font into the device context and delete the old one
= DeleteObject (SelectObject (hdc, hFont))
* set text color on a transparent background
= SetTextColor (hdc, lnColor)
= SetBkMode (hdc, TRANSPARENT)
* print text
= TextOut (hdc, x, Y, lcText, Len(lcText))
* release system resources
= DeleteObject (hFont)
= ReleaseDC (HWnd, hdc)
Endproc
Procedure Load
Declare Integer CreateFont In gdi32;
INTEGER nHeight, Integer nWidth,;
INTEGER nEscapement, Integer nOrientation,;
INTEGER fnWeight, Integer fdwItalic,;
INTEGER fdwUnderline, Integer fdwStrikeOut,;
INTEGER fdwCharSet,;
INTEGER fdwOutputPrecision,;
INTEGER fdwClipPrecision,;
INTEGER fdwQuality,;
INTEGER fdwPitchAndFamily,;
STRING lpszFace
Declare Integer TextOut In gdi32;
INTEGER hdc, Integer x, Integer Y,;
STRING lpString, Integer nCount
Declare Integer GetActiveWindow In user32
Declare Integer GetWindowDC In user32 Integer HWnd
Declare Integer DeleteObject In gdi32 Integer hObject
Declare Integer ReleaseDC In user32;
INTEGER HWnd, Integer hdc
Declare Integer SetTextColor In gdi32;
INTEGER hdc, Integer crColor
Declare Integer SelectObject In gdi32;
INTEGER hdc, Integer hObject
Declare Integer SetBkMode In gdi32;
INTEGER hdc, Integer iBkMode
Declare Integer SetTextColor In gdi32;
INTEGER hdc, Integer crColor
Endproc
Procedure timer1.Timer
This.Enabled=.F.
Local lpString,hwindow,lnAngle
hwindow=Thisform.HWnd
lpString = "This defines a font and print in window through its handle"
= Thisform._print (hwindow,20,30,18,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), 0,"Georgia")
lpString = "This defines a font and print in window through its handle"
= Thisform._print (hwindow,20,50,20,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), 0,"Times New Roman")
lpString = "This defines a font and print in window through its handle"
= Thisform._print (hwindow,20,80,16,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), 0,"Times New Roman")
lpString ="This defines a font and print in window through its handle"
= Thisform._print (hwindow,20,100,16,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), 0,"Arial black")
lpString ="This defines a font and print in window through its handle"
= Thisform._print (hwindow,20,120,16,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), 0,"Times New Roman")
lpString ="This defines a font and print in window through its handle-TAHOMA "
= Thisform._print (hwindow,100,150,20,lpString, Rgb(255,0,0), 0,"TAHOMA")
lpString ="Hello world"
For lnAngle=0 To 10*360 Step 90
= Thisform._print (hwindow,200,340,30,lpString, Rgb(255*Rand(),255*Rand(),255*Rand()), lnAngle,"Georgia")
Endfor
lpString ="Hello world !"
= Thisform._print (hwindow,450,350,50,lpString, Rgb(0,255,0), 0,"Courier New")
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: asup
*End code
![this is similar to print vfp method [form.Print [(cText, iCurrentX, iCurrentY)]]](http://img.over-blog-kiwi.com/1/43/54/07/20150329/ob_322143_demo15.png)
this is similar to print vfp method [form.Print [(cText, iCurrentX, iCurrentY)]]
*13*
*the fonts folder properties by script
*Begin code
Local yrep
yrep=Addbs(Getenv("WINDIR"))+"fonts\"
If Empty(yrep)
Retu
Endi
#Define CSIDL_WINDOWS 36
Local oShell32, oFolder, oFolderItem
*--- Creating a shell application object
oShell32 = Createobject("Shell.Application")
oFolder = oShell32.NameSpace(yrep) &&CSIDL_WINDOWS)
*--- Checking Folder object validation
If Vartype(oFolder)="O"
*--- Retrieve the FolderItem object
oFolderItem = oFolder.Self
*--- Validation...
If Vartype( oFolderItem)="O"
*--- Invoking the verb *Properties*
oFolderItem.InvokeVerb("Properties")
Endi
oFolderItem = Null
Endi
*--- Cleaning objects
oFolder = Null
oShell32 = Null
*end code
*14*
*This is a mixed code vfp-html-css to draw 3D text in web page
*this uses the vfp browser (emulated as IE11 here) and draws 24 3D text.Habitually this code works only in modern browser
*but with emulation this works as well.
*-input are the text, the fontname,fontsize , forecolor and color of shadow
*I added the windows capture tool if anyone wants to capture the 3d text region.
*Begin code
Publi yform
yform=Newobject("y3dfonts")
yform.Show
Read Events
Return
*
Define Class y3Dfonts As Form
Height = 563
Width = 913
ShowWindow = 2
AutoCenter = .T.
Caption = "3d Web fonts in emulated vfp browser (here as IE11)"
Name = "Form1"
Add Object obrowser As OleControl With ;
oleclass="shell.explorer.2",;
Top = 0, ;
Left = 0, ;
Height = 576, ;
Width = 901, ;
Anchor = 15, ;
Name = "oBrowser"
Procedure ybuild
Local ytext
ytext=Inputbox("your text here","","Your text here")
If Empty(m.ytext)
Return .F.
Endi
Local xfont,xsize
xfont=Getfont()
If Empty(m.xfont)
xfont="Eater"
xsize="120"
Else
xfontname=Getwordnum(m.xfont,1,",")
xsize =Getwordnum(m.xfont,2,",")
Endi
Local ysize
ysize=Inputbox("Confirm the fontsize or upgrade++ maxi=250","",m.xsize)
If Empty(m.ysize) Or Val(m.ysize)>250
ysize=m.xsize
Endi
xsize=m.ysize
_vfp.Visible=.T.
Messagebox("get the text Forecolor ",0+32+4096,2000)
Local RGBChr,xcolor
m.RGBChr=Left(BinToC(Getcolor(),'R'),3)
If Empty(m.RGBChr)
xcolor="rgb(255,255,255)"
Else
R=Asc(Substr(m.RGBChr,1,1)) && RED
G=Asc(Substr(m.RGBChr,2,1)) && GREEN
B=Asc(Substr(m.RGBChr,3,1)) && BLUE
xcolor="rgb("+Trans(m.R)+","+Trans(m.G)+","+Trans(m.B)+")"
Endi
*shadow
Messagebox("get the text Shadowcolor ",0+32+4096,2000)
Local RGBChrs,xcolors
m.RGBChrs=Left(BinToC(Getcolor(),'R'),3)
If Empty(m.RGBChrs)
xcolor="rgb(0,0,0)"
R=0
G=0
B=0
Else
R=Asc(Substr(m.RGBChrs,1,1)) && RED
G=Asc(Substr(m.RGBChrs,2,1)) && GREEN
B=Asc(Substr(m.RGBChrs,3,1)) && BLUE
xcolors="rgb("+Trans(m.R)+","+Trans(m.G)+","+Trans(m.B)+")"
Endi
_vfp.Visible=.F.
*custom shadow with color shadow above (multi shadows method)
x=m.xcolors
R1=R-9
g1=G-9
b1=B-9
If R1<0
R1=0
Endi
If g1<0
g1=0
Endi
If b1<0
b1=0
Endi
x1="rgb("+Trans(R1)+","+Trans(g1)+","+Trans(b1)+")"
R2=R1-9
g2=g1-9
b2=b1-9
If R2<0
R2=0
Endi
If g2<0
g2=0
Endi
If b2<0
b2=0
Endi
x2="rgb("+Trans(R2)+","+Trans(g2)+","+Trans(b2)+")"
R3=R2-9
g3=g2-9
b3=b2-9
If R3<0
R3=0
Endi
If g3<0
g3=0
Endi
If b3<0
b3=0
Endi
x3="rgb("+Trans(R3)+","+Trans(g3)+","+Trans(b3)+")"
R4=R3-9
g4=g3-9
b4=b3-9
If R4<0
R4=0
Endi
If g4<0
g4=0
Endi
If b4<0
b4=0
Endi
x4="rgb("+Trans(R4)+","+Trans(g4)+","+Trans(b4)+")"
R5=R4-9
g5=g4-9
b5=b4-9
If R5<0
R5=0
Endi
If g5<0
g5=0
Endi
If b5<0
b5=0
Endi
x5="rgb("+Trans(R5)+","+Trans(g5)+","+Trans(b5)+")"
R6=R5-9
g6=g5-9
b6=b5-9
If R6<0
R6=0
Endi
If g6<0
g6=0
Endi
If b6<0
b6=0
Endi
x6="rgb("+Trans(R6)+","+Trans(g6)+","+Trans(b6)+")"
R7=R6-9
g7=g6-9
b7=b6-9
If R7<0
R7=0
Endi
If g7<0
g7=0
Endi
If b7<0
b7=0
Endi
x7="rgb("+Trans(R7)+","+Trans(g7)+","+Trans(b7)+")"
R8=R7-9
g8=g7-9
b8=b7-9
If R8<0
R8=0
Endi
If g8<0
g8=0
Endi
If b8<0
b8=0
Endi
x8="rgb("+Trans(R8)+","+Trans(g8)+","+Trans(b8)+")"
R9=R8-9
g9=g8-9
b9=b8-9
If R9<0
R9=0
Endi
If g9<0
g9=0
Endi
If b9<0
b9=0
Endi
x9="rgb("+Trans(R9)+","+Trans(g9)+","+Trans(b9)+")"
R10=R8-9
g10=g8-9
b10=b8-9
If R10<0
R10=0
Endi
If g10<0
g10=0
Endi
If b10<0
b10=0
Endi
x10="rgb("+Trans(R10)+","+Trans(g10)+","+Trans(b10)+")"
TEXT to m.yshadow textmerge noshow
.yshadow { text-shadow: <<m.x>> 0px 0px 0px, <<m.x1>> 1px -1px 0px, <<m.x2>> 2px -2px 0px, <<m.x3>> 3px -3px 0px, <<m.x4>> 4px -4px 0px, <<m.x5>> 5px -5px 0px, <<m.x6>> 6px -6px 0px, <<m.x7>> 7px -7px 0px, <<m.x8>> 8px -8px 0px, <<m.x9>> 9px -9px 0px, <<m.x10>> 10px -10px 0px, rgba(0, 0, 0, 0.597656) 11px -11px 10px, rgba(0, 0, 0, 0.496094) 11px -11px 1px, rgba(0, 0, 0, 0.199219) 0px 0px 10px; }
ENDTEXT
x=m.xcolors
R1=R-5
g1=G-5
b1=B-5
If R1<0
R1=0
Endi
If g1<0
g1=0
Endi
If b1<0
b1=0
Endi
x1="rgb("+Trans(R1)+","+Trans(g1)+","+Trans(b1)+")"
R2=R1-5
g2=g1-5
b2=b1-5
If R2<0
R2=0
Endi
If g2<0
g2=0
Endi
If b2<0
b2=0
Endi
x2="rgb("+Trans(R2)+","+Trans(g2)+","+Trans(b2)+")"
R3=R2-5
g3=g2-5
b3=b2-5
If R3<0
R3=0
Endi
If g3<0
g3=0
Endi
If b3<0
b3=0
Endi
x3="rgb("+Trans(R3)+","+Trans(g3)+","+Trans(b3)+")"
R4=R3-5
g4=g3-5
b4=b3-5
If R4<0
R4=0
Endi
If g4<0
g4=0
Endi
If b4<0
b4=0
Endi
x4="rgb("+Trans(R4)+","+Trans(g4)+","+Trans(b4)+")"
R5=R4-5
g5=g4-5
b5=b4-5
If R5<0
R5=0
Endi
If g5<0
g5=0
Endi
If b5<0
b5=0
Endi
x5="rgb("+Trans(R5)+","+Trans(g5)+","+Trans(b5)+")"
R6=R5-5
g6=g5-5
b6=b5-5
If R6<0
R6=0
Endi
If g6<0
g6=0
Endi
If b6<0
b6=0
Endi
x6="rgb("+Trans(R6)+","+Trans(g6)+","+Trans(b6)+")"
R7=R6-5
g7=g6-5
b7=b6-5
If R7<0
R7=0
Endi
If g7<0
g7=0
Endi
If b7<0
b7=0
Endi
x7="rgb("+Trans(R7)+","+Trans(g7)+","+Trans(b7)+")"
R8=R7-5
g8=g7-5
b8=b7-5
If R8<0
R8=0
Endi
If g8<0
g8=0
Endi
If b8<0
b8=0
Endi
x8="rgb("+Trans(R8)+","+Trans(g8)+","+Trans(b8)+")"
R9=R8-5
g9=g8-5
b9=b8-5
If R9<0
R9=0
Endi
If g9<0
g9=0
Endi
If b9<0
b9=0
Endi
x9="rgb("+Trans(R9)+","+Trans(g9)+","+Trans(b9)+")"
R10=R8-5
g10=g8-5
b10=b8-5
If R10<0
R10=0
Endi
If g10<0
g10=0
Endi
If b10<0
b10=0
Endi
x10="rgb("+Trans(R10)+","+Trans(g10)+","+Trans(b10)+")"
R11=R10-5
g11=g10-5
b11=b10-5
If R11<0
R11=0
Endi
If g11<0
g11=0
Endi
If b11<0
b11=0
Endi
x11="rgb("+Trans(R11)+","+Trans(g11)+","+Trans(b11)+")"
R12=R11-5
g12=g11-5
b12=b11-5
If R12<0
R12=0
Endi
If g12<0
g12=0
Endi
If b12<0
b12=0
Endi
x12="rgb("+Trans(R12)+","+Trans(g12)+","+Trans(b12)+")"
R13=R12-5
g13=g12-5
b13=b12-5
If R13<0
R13=0
Endi
If g13<0
g13=0
Endi
If b13<0
b13=0
Endi
x13="rgb("+Trans(R13)+","+Trans(g13)+","+Trans(b13)+")"
R14=R13-5
g14=g13-5
b14=b13-5
If R14<0
R14=0
Endi
If g14<0
g14=0
Endi
If b14<0
b14=0
Endi
x14="rgb("+Trans(R14)+","+Trans(g14)+","+Trans(b14)+")"
R15=R14-5
g15=g14-5
b15=b14-5
If R15<0
R15=0
Endi
If g15<0
g15=0
Endi
If b15<0
b15=0
Endi
x15="rgb("+Trans(R15)+","+Trans(g15)+","+Trans(b15)+")"
R16=R15-5
g16=g15-5
b16=b15-5
If R16<0
R16=0
Endi
If g16<0
g16=0
Endi
If b16<0
b16=0
Endi
x16="rgb("+Trans(R16)+","+Trans(g16)+","+Trans(b16)+")"
R17=R16-5
g17=g16-5
b17=b16-5
If R17<0
R17=0
Endi
If g17<0
g17=0
Endi
If b17<0
b17=0
Endi
x17="rgb("+Trans(R17)+","+Trans(g17)+","+Trans(b17)+")"
R18=R17-5
g18=g17-5
b18=b17-5
If R18<0
R18=0
Endi
If g18<0
g18=0
Endi
If b18<0
b18=0
Endi
x18="rgb("+Trans(R18)+","+Trans(g18)+","+Trans(b18)+")"
R19=R18-5
g19=g18-5
b19=b18-5
If R19<0
R19=0
Endi
If g19<0
g19=0
Endi
If b19<0
b19=0
Endi
x19="rgb("+Trans(R19)+","+Trans(g19)+","+Trans(b19)+")"
R20=R19-5
g20=g19-5
b20=b19-5
If R20<0
R20=0
Endi
If g20<0
g20=0
Endi
If b20<0
b20=0
Endi
x20="rgb("+Trans(R20)+","+Trans(g20)+","+Trans(b20)+")"
R21=R20-5
g21=g20-5
b21=b20-5
If R21<0
R21=0
Endi
If g21<0
g21=0
Endi
If b21<0
b21=0
Endi
x21="rgb("+Trans(R21)+","+Trans(g21)+","+Trans(b21)+")"
TEXT to m.yshadow1 textmerge noshow
.yshadow1 { text-shadow:<<m.x1>> 0px 0px 0px, <<m.x2>> 1px -1px 0px, <<m.x3>> 2px -2px 0px, <<m.x5>> 4px -4px 0px, <<m.x6>> 5px -5px 0px, <<m.x7>> 6px -6px 0px, <<m.x8>> 7px -7px 0px, <<m.x10>> 9px -9px 0px, <<m.x12>> 11px -11px 0px, <<m.x13>> 12px -12px 0px, <<m.x14>> 13px -13px 0px, <<m.x15>> 14px -14px 0px, <<m.x16>> 15px -15px 0px, <<m.x17>> 16px -16px 0px, <<m.x18>> 17px -17px 0px, <<m.x19>> 18px -18px 0px, <<m.x20>> 19px -19px 0px, <<m.x21>> 20px -20px 0px, rgba(0, 0, 0, 0.6) 21px -21px 20px, rgba(0, 0, 0, 0.498039) 21px -21px 1px, rgba(0, 0, 0, 0.2) 0px 0px 20px; }
ENDTEXT
Local m.myvar
TEXT to m.myvar textmerge noshow
<!DOCTYPE html>
<html>
<head>
<meta charset='utf-8'/>
<title>3D Text with CSS - 24 styles</title>
<style>
.pre-wrap {
border: 1px dashed #424242;
width: 400px;
margin-right: auto;
margin-left: auto;
background-color: #000;
margin-bottom: 40px;
padding: 15px 49px;
}
@font-face {
font-family: 'Audiowide';
font-style: normal;
font-weight: 400;
src: local('Audiowide'), local('Audiowide-Regular'), url(https://themes.googleusercontent.com/static/fonts/audiowide/v1/7pSgz2MbVvTCvvm7vukSHz8E0i7KZn-EPnyo3HZu7kw.woff) format('woff');
}
@font-face {
font-family: 'Caesar Dressing';
font-style: normal;
font-weight: 400;
src: local('Caesar Dressing'), local('CaesarDressing-Regular'), url(https://themes.googleusercontent.com/static/fonts/caesardressing/v2/2T_WzBgE2Xz3FsyJMq34T2P6V2CHcxaChb7jOf5qsHM.woff) format('woff');
}
@font-face {
font-family: 'Chela One';
font-style: normal;
font-weight: 400;
src: local('Chela One'), local('ChelaOne-Regular'), url(https://themes.googleusercontent.com/static/fonts/chelaone/v1/0uXFKi46eRCbFWkdb_7tDj8E0i7KZn-EPnyo3HZu7kw.woff) format('woff');
}
@font-face {
font-family: 'Eater';
font-style: normal;
font-weight: 400;
src: local('Eater'), local('Eater-Regular'), url(https://themes.googleusercontent.com/static/fonts/eater/v2/k0SThm2alOUIrUHaTqmh7A.woff) format('woff');
}
@font-face {
font-family: 'Henny Penny';
font-style: normal;
font-weight: 400;
src: local('Henny Penny'), local('HennyPenny-Regular'), url(https://themes.googleusercontent.com/static/fonts/hennypenny/v1/5KmZ_gfx8tPgQLMk4S-PvobN6UDyHWBl620a-IRfuBk.woff) format('woff');
}
@font-face {
font-family: 'Nova Cut';
font-style: normal;
font-weight: 400;
src: local('Nova Cut'), local('NovaCut'), url(https://themes.googleusercontent.com/static/fonts/novacut/v5/b5vZEwVUBPIS_-LkFQ96FvesZW2xOQ-xsNqO47m55DA.woff) format('woff');
}
@font-face {
font-family: 'Ribeye Marrow';
font-style: normal;
font-weight: 400;
src: local('Ribeye Marrow'), local('RibeyeMarrow-Regular'), url(https://themes.googleusercontent.com/static/fonts/ribeyemarrow/v3/q7cBSA-4ErAXBCDFPrhlYyMPedbYL2I9PAP99IkxF5M.woff) format('woff');
}
@font-face {
font-family: 'Share Tech';
font-style: normal;
font-weight: 400;
src: local('Share Tech'), local('ShareTech-Regular'), url(https://themes.googleusercontent.com/static/fonts/sharetech/v1/riJWcvd3sYdxJpiCWZvUGBsxEYwM7FgeyaSgU71cLG0.woff) format('woff');
}
@font-face {
font-family: 'Sofadi One';
font-style: normal;
font-weight: 400;
src: local('Sofadi One'), local('SofadiOne-Regular'), url(https://themes.googleusercontent.com/static/fonts/sofadione/v1/T28dLve-Ycdi1yHVhvAlyRsxEYwM7FgeyaSgU71cLG0.woff) format('woff');
}
@font-face {
font-family: 'Unica One';
font-style: normal;
font-weight: 400;
src: local('Unica One'), local('UnicaOne-Regular'), url(https://themes.googleusercontent.com/static/fonts/unicaone/v1/Zxq4PdUSc3GE41eti2ZndD8E0i7KZn-EPnyo3HZu7kw.woff) format('woff');
}
body { margin 0px; text-align:center; font-family:Arial; font-size:14px; color:#ffffff; font-weight:normal;}
span, h1 { margin: 0px; padding:0px; }
.blackground { background-color:#000000 ; padding:10px; }
.ycolor { color:<<m.xcolor>>; font-family:'<<m.xfontname>>'; font-size:<<m.xsize>>px; }
.white { color:rgb(255,255,255); font-family:'eater'; font-size:<<m.xsize>>px; }
.gold { color:RGB(250,250,210); font-family:'Georgia'; font-size:<<m.xsize>>px; }
.yellow { color:rgb(255, 242, 0); font-family:'Henny Penny'; font-size:<<m.xsize>>px; }
.red { color:rgb(255, 10, 0); font-family:'Eater'; font-size:<<m.xsize>>px; }
.blue { color:rgb(10, 10, 255); font-family:'Eater'; font-size:<<m.xsize>>px; }
.ytyp1 { color:<<m.xcolor>>; font-family:'Audiowide'; font-size:<<m.xsize>>px; }
.ytyp2 { color:<<m.xcolor>>; font-family:'Caesar Dressing'; font-size:<<m.xsize>>px; }
.ytyp3 { color:<<m.xcolor>>; font-family:'Chela One'; font-size:<<m.xsize>>px; }
.ytyp4 { color:<<m.xcolor>>; font-family:'Nova Cut'; font-size:<<m.xsize>>px; }
.ytyp5 { color:<<m.xcolor>>; font-family:'Ribeye Marrow'; font-size:<<m.xsize>>px; }
.ytyp6 { color:<<m.xcolor>>; font-family:'Share Tech'; font-size:<<m.xsize>>px; }
.ytyp7 { color:<<m.xcolor>>; font-family:'Sofadi One'; font-size:<<m.xsize>>px; }
.ytyp8 { color:<<m.xcolor>>; font-family:'Unica One'; font-size:<<m.xsize>>px; }
.tr-orange-2 { text-shadow:rgb(236, 147, 0) 0px 0px 0px, rgb(228, 139, 0) 1px -1px 0px, rgb(219, 130, 0) 2px -2px 0px, rgb(210, 121, 0) 3px -3px 0px, rgb(202, 113, 0) 4px -4px 0px, rgb(193, 104, 0) 5px -5px 0px, rgb(184, 95, 0) 6px -6px 0px, rgb(175, 86, 0) 7px -7px 0px, rgb(167, 78, 0) 8px -8px 0px, rgb(158, 69, 0) 9px -9px 0px, rgb(149, 60, 0) 10px -10px 0px, rgba(0, 0, 0, 0.597656) 11px -11px 10px, rgba(0, 0, 0, 0.496094) 11px -11px 1px, rgba(0, 0, 0, 0.199219) 0px 0px 10px; }
.tr-green-4 { text-shadow:rgb(18, 195, 2) 0px 0px 0px, rgb(13, 190, 0) 1px -1px 0px, rgb(9, 186, 0) 2px -2px 0px, rgb(5, 182, 0) 3px -3px 0px, rgb(0, 177, 0) 4px -4px 0px, rgb(0, 173, 0) 5px -5px 0px, rgb(0, 169, 0) 6px -6px 0px, rgb(0, 164, 0) 7px -7px 0px, rgb(0, 160, 0) 8px -8px 0px, rgb(0, 156, 0) 9px -9px 0px, rgb(0, 151, 0) 10px -10px 0px, rgb(0, 147, 0) 11px -11px 0px, rgb(0, 142, 0) 12px -12px 0px, rgb(0, 138, 0) 13px -13px 0px, rgb(0, 134, 0) 14px -14px 0px, rgb(0, 129, 0) 15px -15px 0px, rgb(0, 125, 0) 16px -16px 0px, rgb(0, 121, 0) 17px -17px 0px, rgb(0, 116, 0) 18px -18px 0px, rgb(0, 112, 0) 19px -19px 0px, rgb(0, 108, 0) 20px -20px 0px, rgba(0, 0, 0, 0.6) 21px -21px 20px, rgba(0, 0, 0, 0.498039) 21px -21px 1px, rgba(0, 0, 0, 0.2) 0px 0px 20px; }
<<yshadow>>
<<yshadow1>>
</style>
</head>
<body class='blackground' oncontextmenu="return false;">
<h2> 24 3D Text style</h2>
<br><br><br>
<H1 class='ycolor yshadow'> <<m.ytext>> </H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: <<M.XFONTNAME>></pre>
</div></center><br>
</div>
<br><br>
<H1 class='ycolor yshadow1'> <<m.ytext>> </H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: <<M.XFONTNAME>></pre>
</div></center><br>
</div>
<br><br>
<hr>
<H1 class='ycolor tr-orange-2'> <<m.ytext>> </H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: ycolor tr-orange-2</pre>
</div></center><br>
</div>
<br><br>
<H1 class='ycolor tr-green-4'><<m.ytext>></H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: ycolor tr-green-4</pre>
</div></center><br>
</div>
<br><br>
<HR>
<span class='gold tr-orange-2'><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: gold tr-orange-2</pre>
</div></center><br>
</div>
<br><br>
<H1 class='red tr-orange-2' ><<m.ytext>></H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE: red tr-orange-2</pre>
</div></center><br>
</div>
<br><br>
<H1 class='blue tr-orange-2' ><<m.ytext>></H1>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:blue tr-orange-2</pre>
</div></center><br>
</div>
<br><br>
<h1 class='yellow tr-green-4' ><<m.ytext>></h1>
<center><div class="pre-wrap">
<pre> STYLE:yellow tr-green-4</pre>
</div></center><br>
</div>
<HR>
<br><br><br> <br>
<span class='ytyp1 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp1 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp1 tr-green-4' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp1 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp2 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp2 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp2 tr-green-4' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp2 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp3 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp3 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp3 tr-green-4' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp3 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp4 tr-orange-2' ><<m.ytext>></span>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp4 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp4 tr-green-4' ><<m.ytext>></span>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp4 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp5 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp5 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp5 tr-green-4' ><<m.ytext>></span>
<center><div class="pre-wrap">
<pre> STYLE:ytyp5 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp6 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp6 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp6 tr-green-4' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp6 tr-green-4</pre>
</div></center>
<br><br>
<span class='ytyp7 tr-orange-2' ><<m.ytext>></span>
<br><br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp7 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp7 tr-green-4' ><<m.ytext>></span>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp7 tr-green-4</pre>
</div></center>
<br><br>
<br><br>
<span class='ytyp8 tr-orange-2' ><<m.ytext>></span>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp8 tr-orange-2</pre>
</div></center>
<br><br>
<span class='ytyp8 tr-green-4' ><<m.ytext>></span>
<br><br>
<center><div class="pre-wrap">
<pre> STYLE:ytyp8 tr-green-4</pre>
</div></center>
<br><br>
</body>
</html>
ENDTEXT
Set Safe Off
Local lcdest
lcdest=Addbs(Sys(2023))+"mytext.html"
Strtofile(m.myvar,m.lcdest)
Set Safe On
Thisform.obrowser.Navigate(m.lcdest)
Inkey(1)
Run/N snippingtool.Exe
Endproc
Procedure Init
Thisform.ybuild()
Endproc
Procedure obrowser.Init
This.silent=.T.
Endproc
Procedure Destroy
Local m.myvar,oshell,lcdest &&kill the processsnippingtool.exe
TEXT to m.myvar noshow
TaskKill /IM snippingtool.exe
ENDTEXT
m.lcdest=Addbs(Sys(2023))+"asup.bat"
Strtofile(m.myvar,m.lcdest)
oshell=Newobject("wscript.shell")
oshell.Run(m.lcdest,0,.T.)
oshell=Null
Dele File (lcdest)
Clea Events
Endproc
Enddefine
*
*-- EndDefine: asup
*End code
*--Subject :Special characters & customize charmap on a form and working with an rtfbox
*Begin code
Public oform
oform=Newobject("form1")
oform.Show
Read Events
Return
Define Class form1 As Form
Top = -1
Left = 11
Height = 532
Width = 980
ShowWindow = 2
Caption = "Special Characters"
KeyPreview = .T.
yhwnd = 0
Name = "Form1"
Add Object olecontrol1 As OleControl With ;
oleclass="Richtext.RichTextCtrl.1",;
Top = 12, ;
Left = 516, ;
Height = 312, ;
Width = 228, ;
scrollbars=2,;
Name = "Olecontrol1"
Add Object command1 As CommandButton With ;
Top = 360, ;
Left = 672, ;
Height = 27, ;
Width = 144, ;
Caption = "CODES ASCII with font", ;
Name = "Command1"
Add Object label1 As Label With ;
FontBold = .T., ;
FontSize = 12, ;
BackStyle = 0, ;
Caption = "", ;
Height = 37, ;
Left = 648, ;
Top = 396, ;
Width = 264, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label1"
Add Object timer1 As Timer With ;
Top = 12, ;
Left = 384, ;
Height = 23, ;
Width = 23, ;
Enabled = .F., ;
Interval = 700, ;
Name = "Timer1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontSize = 12, ;
WordWrap = .T., ;
BackStyle = 0, ;
Caption = "Choice MS Reference sans serif font -clic Charmap character-Drag drop any character unicode from charmap to the RTFBOX ", ;
Height = 38, ;
Left = 528, ;
Top = 444, ;
Width = 371, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label2"
Add Object label3 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
BackStyle = 0, ;
Caption = "CTRL+A select all CTRL+V paste CTRL+C copy CTRL+X cut", ;
Height = 20, ;
Left = 529, ;
Top = 328, ;
Width = 437, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label3"
Procedure Init
_Screen.WindowState=1
Run/N "charmap"
Inkey(1)
* find charmap hwnd
Thisform.yhwnd = FindWindow(Null, "Table des caractères") &&Warning use locale title of charmap (depends on language set on machine
SetParent(Thisform.yhwnd,Thisform.HWnd)
This.timer1.Enabled=.T.
Endproc
Procedure Resize
SetWindowPos(Thisform.yhwnd, 1,This.Left, This.Top-30,500, 530,0)
BringWindowToTop(Thisform.yhwnd)
Endproc
Procedure Click
Thisform.Resize
Endproc
Procedure Load
Declare Long FindWindow In WIN32API String, String
Declare Long SetWindowPos In WIN32API Integer,Integer,Integer,Integer,Integer,Integer,Integer
Declare Long ShowWindow In WIN32API Long, Long
Declare Integer SetParent In user32;
INTEGER hWndChild,;
INTEGER hWndNewParent
Declare Integer BringWindowToTop In user32 Integer
Endproc
Procedure olecontrol1.Init
This.Text=""
This.AutoVerbMenu=.T.
Endproc
Procedure command1.Click
#Define crlf Chr(13)+Chr(10)
xfont=Getfont()
Thisform.olecontrol1.Font.Name=xfont
Thisform.label1.Caption=xfont
aa=""
For i=1 To 255
aa=aa+Trans(i)+" "+Chr(i)+crlf
Endfor
Thisform.olecontrol1.Text=(aa)
Endproc
Procedure timer1.Timer
Thisform.WindowState=1
Thisform.WindowState=0
This.Enabled=.F.
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: form1
*End code
*16*
*This code use fontname,fontsize to write on the imgcanvas control
*the string is confined in a rectangle with the function measurestring(string,font).its similar to txtWidth for vfp texts.
*Point to system.app and gdiplusX class to make this code running.
*BEGIN CODE
Do Locfile("system.app")
Set Classlib To Locfile("gdiplusX") AddI
Publi yform
yform=Newobject("asup")
Release Classlib "gdiplusX"
yform.Show
Read Events
*
Define Class asup As Form
Height = 594
Width = 998
ShowWindow = 2
AutoCenter = .T.
Caption = "Drawing with gdiplusX using fonts,measurestring"
Name = "Form1"
Add Object imgcanvas1 As imgcanvas With ;
Height = 650, ;
Left = 5, ;
Top = 2, ;
Width = 449, ;
Name = "Imgcanvas1"
Procedure ydraw
With Thisform
For i=1 To .ControlCount
Try
With .Controls(i)
.Width=.xwidth
.Draw
Endwith
Catch
Endtry
Endfor
Endwith
Endproc
Procedure yrandcolor
Return _Screen.System.drawing.Color.fromRGB(255*Rand(),255*Rand(),255*Rand())
Endproc
Procedure Activate
this.imgcanvas1.draw
This.ydraw
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure imgcanvas1.Setup
With This
.AddProperty("xwidth",.Width)
.drawWhenInvisible=.T.
Endwith
Endproc
Procedure imgcanvas1.beforedraw
This.Clear
logfx=This.ogfx
With _Screen.System.drawing
logfx.SmoothingMode = .Drawing2D.SmoothingMode.AntiAlias
*text
Local loFont As xfcFont
Local loBrush As xfcLinearGradientBrush
Local loRectangleF As xfcRectangle
Local loSizeF As xfcSizeF
Y=0
For i=8 To 48 Step 4
ystring=Trans(i)+" "+"GdiPlusX sous Visual Foxpro 9"
loFont = .Font.New["Tahoma",;
i, .FontStyle.BoldItalic]
loSizeF = logfx.MeasureString(ystring, loFont)
loRectangleF =.RectangleF.New(0,Y,loSizeF.Width, loSizeF.Height)
Local m.xcolor1,m.xcolor2 As xfccolor
m.color1=Thisform.yrandcolor()
m.color2=Thisform.yrandcolor()
loBrush = .Drawing2D.LinearGradientBrush.New(loRectangleF,m.color1,m.color2,1)
logfx.DrawString(ystring, loFont,loBrush, loRectangleF)
Y=Y+loSizeF.Height+2
If This.Width<loSizeF.Width
This.xwidth=loSizeF.Width+10
Endi
Endfor
Endwith
Endproc
Enddefine
*
*-- EndDefine: asup
*END CODE
Click on code to select [then copy] -click outside to deselect
*17*
*this code retrieves 5 special fonts can be usefully used on codes in place of images.
Publi yform
yform=Newobject("yFS")
yform.Show
Read Events
Retu
*
Define Class yFS As Form
BorderStyle = 0
Height = 515
Width = 460
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "Special fonts"
MaxButton = .F.
Name = "Form1"
Add Object grid1 As Grid With ;
anchor=15, ;
Height = 516, ;
Left = 4, ;
Top = 0, ;
Width = 460, ;
Name = "Grid1"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
Sele ycurs
Wait Window loObject.FontName +" - ("+Trans(Recno())+")" Nowait
Endproc
Procedure Init
Close Data All
Crea Cursor ycurs (cha1 c(10),cha2 c(10),cha3 c(10),cha4 c(10),ch5 c(10))
For i=32 To 255
Insert Into ycurs Values (Chr(i),Chr(i),Chr(i),Chr(i),Chr(i))
Endfor
With Thisform.grid1
.RecordSource="ycurs"
.column1.FontName="webdings"
.column2.FontName="wingdings"
.column3.FontName="wingdings 2"
.column4.FontName="wingdings 3"
.column5.FontName="matterOffact"
.MousePointer=15
.FontBold=.T.
.FontSize=20
.DeleteMark=.F.
.GridLines=0
.RecordMark=.F.
.ForeColor=255
.BackColor=Rgb(0,215,0)
.ReadOnly=.T.
.SetAll("fontsize",12,"header")
.column1.header1.Caption="Webdings"
.column2.header1.Caption="Wingdings"
.column3.header1.Caption="Wingding 2"
.column4.header1.Caption="Wingdings 3"
.column5.header1.Caption="MatterOfact"
.AutoFit
Locate
.Refresh
Endwith
With Thisform.grid1
For i=1 To .ColumnCount
Bindevent(.Columns(i).text1,"mousedown",Thisform,"my")
Endfor
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: yFS
Click on code to select [then copy] -click outside to deselect
*this codes uses the chesstype.ttf font in a label to show the time.
*chesstype.ttf can be downloaded at: http://dl.static.1001fonts.net/niceid/c/h/chesstype.zip
*SIMPLY COPY THE TTF TO C/\WINDOW\FONTS\ ITS AUTOINSTALLS.
publi yform
yform=newObject("ychesstype")
yform.show
read events
retu
*
DEFINE CLASS ychesstype AS form
Top = 0
Left = 101
Height = 140
Width = 474
Caption = "Time() with chesstype.ttf"
BackColor = RGB(0,0,0)
Name = "Form1"
ADD OBJECT label1 AS label WITH ;
FontName = "ChessType", ;
FontSize = 72, ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = (time()), ;
Height = 121, ;
Left = 12, ;
Top = 12, ;
Width = 457, ;
ForeColor = RGB(0,255,0), ;
BackColor = RGB(0,0,0), ;
Name = "Label1"
ADD OBJECT timer1 AS timer WITH ;
Top = 12, ;
Left = 24, ;
Height = 23, ;
Width = 23, ;
Interval = 1000, ;
Name = "Timer1"
PROCEDURE label1.Init
thisform.label1.caption=time()
ENDPROC
PROCEDURE timer1.Timer
thisform.label1.caption=time()
ENDPROC
PROCEDURE DESTROY
CLEA EVENTS
ENDPROC
ENDDEFINE
*
*-- EndDefine: ychesstype
