XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
RTF: Schriftart ändern
WindowTitle Bitte Text mit der Maus markieren ...
window 50,50-500,400
settruecolor 1
usermessages 16---WM_CLOSE > Schliessen abfangen
usefont ms sans serif,15,7,0,0,0
setdialogfont 1
declare rtf#,Edit&,dll&,Test1%,Test2%,Test3%
dim rtf#,60
dll&=usedll(riched32.dll)
Edit&=control(RichEdit,,$54315004,180,10,300,200,%hwnd,100,%hinstance,$200)
settext Edit&,Test: LaberLaberLaber
sendmessage(Edit&,1087,0,1)----------EM_HIDESELECTION => none
Test1%=create(button,%hwnd,Arial,10,10,150,22)
Test2%=create(button,%hwnd,Times New Roman,10,40,150,22)
Test3%=create(button,%hwnd,WingDings,10,70,150,22)
def CreateFontIndirect(1) !GDI32,CreateFontIndirectA
def SelectObject(2) !GDI32,SelectObject
def GetTextCharset(1) !GDI32,GetTextCharset

proc rtf-SetFont---------------------------------------------------------------------SetFont

    parameters a$
    declare a&,b&
    --Charset des Fonts ermitteln (ANSI,ASCII,Symbol usw.)
    clear rtf#
    byte rtf#,23=1
    string rtf#,28=a$
    b&=CreateFontIndirect(rtf#)
    SelectObject(%hdc,b&)
    a&=GetTextCharset(%hdc)
    deleteobject b&
    --Font zuordnen
    clear rtf#
    long rtf#,0=60
    long rtf#,4=$28000000--dwMask > CFM_FACE
    byte rtf#,24=a&--------CharSet des Fonts
    string rtf#,26=a$
    sendmessage(Edit&,1092,1,rtf#)-EM_SETCHARFORMAT
    endproc------------------------------------------------------------------------------------

    while 1

        waitinput
        case %umessage=16:break

        if getfocus(Test1%)

            rtf-SetFont Arial

        elseif getfocus(Test2%)

            rtf-SetFont Times New Roman

        elseif getfocus(Test3%)

            rtf-SetFont Wingdings

        endif

    endwhile

    destroywindow(Edit&)
    case dll&:FreeDLL dll&
    dispose rtf#