Working with fonts

Published on by Yousfi Benameur

Below 17 codes on the fonts subjects, listing,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


Working with  fonts

*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


Working with  fonts
Working with  fonts
Working with  fonts

*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


Working with  fonts

*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


Working with  fonts

*!* 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

 


Working with  fonts

*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

 


Working with  fonts
Working with  fonts

*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

 


Working with  fonts

*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

 

*Install any valid font on system

*Begin code

 oShell = CreateObject("Shell.Application")
objFolder = oShell.Namespace("<Folder or Share Location>")
objFolderItem = objFolder.ParseName("<TTF File Name>")
objFolderItem.InvokeVerb("Install")

*End code

 


*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

 


Working with  fonts
Working with  fonts

*10*

*this code use a menu to see all fonts

*Begin code

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

*End code
*adapted from http://fox.wikis.com/wc.dll?Wiki~AnEasyWayToPreviewFonts~Wiki


Working with  fonts

*11*

* a font dialog box some similar to  visual foxpro one

* 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

 


Working with  fonts

*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)]]

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

 


Working with  fonts

*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

 


Working with  fonts
Working with  fonts

*--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

 


Working with  fonts

*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


Working with  fonts

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


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

Thai Huynh 07/30/2021 19:47

Hello,
How can i change the default font of the menu in windows 10?
Thanks.

fonts 06/18/2016 11:54

Please Visit On This Site & Get A Lot Of Ideas About .fonts