XProfan

window 400,400
 $H Windows.ph
 $H Messages.ph
usermessages 16
var Ini$="X:Test.ini"************************* Pfad bitte anpassen!

subproc rtf.SetColor------------------------------------rtf.SetColor

    parameters Edit&,Color&
    declare rtf#:dim rtf#,60--CHARFORMAT
    long rtf#,0=60,$40000000,0,0,0,Color&
    sendmessage(Edit&,1092,0,rtf#)-EM_SETCHARFORMAT
    dispose rtf#
    endproc-------------------------------------------------------------

    proc ChooseFont-------------------------------------------ChooseFont

        parameters Log#
        declare a#:dim a#,60--CHOOSEFONT
        long a#,0=60,%hwnd,0,Log#,0,$541,long(Log#,60)
        var Size%=long(Log#,0)
        long b#,0=Size%*~GetDeviceCaps(%hdc,~LOGPIXELSY)/108
        var Ok&=external("comdlg32","ChooseFontA",a#)
        long Log#,0=if(Ok&,long(a#,16)*0.15,Size%)
        long Log#,60=long(a#,24)
        dispose a#
        return Ok&
        endproc-------------------------------------------------------------
        declare b#:dim b#,60+4--LOGFONT + Textfarbe
        var Edit&=create("RichEdit",%hwnd,"RichEdit
        LaberLaber",10,50,300,100)
        var Result&=~GetPrivateProfileStruct("Config","Font",b#,64,addr(Ini$))

        ifnot Result&------------Vorgaben, falls Ini noch nicht vorhanden

            long b#,0=18----------Height (im Dialog angezeigte Größe * 1.5)
            long b#,16=0----------Bold (gesetzt: 700)
            byte b#,20=1,1,0------Italic, Underline, Strikeout
            string b#,28="Arial"--FontName (max. 32 Bytes)
            long b#,60=128--------Farbe

        endif

        var Font&=~CreateFontIndirect(b#)
        setfont Edit&,Font&
        var Color&=long(b#,60)
        rtf("SetColor",Edit&,Color&)

        while 1

            waitinput
            case %umessage=16:break
            Result&=ChooseFont(b#)

            if Result&

                deleteobject Font&
                Font&=~CreateFontIndirect(b#)
                setfont Edit&,Font&
                Color&=long(b#,60)
                rtf("SetColor",Edit&,Color&)

            endif

        endwhile

        deleteobject Font&
        ~WritePrivateProfileStruct("Config","Font",b#,64,addr(Ini$))