Max font size printing to any screen size.

[Pete]

This was just for fun, in response to another forum member looking for a way to wrap a long string around a screen so it nearly fills up the entire screen. In other words, if it is very long, it is printed in a smaller font. Small, it gets printed in a larger font.

It isn't totally goof-proof, so I'm happy to take any comments as to improvements. This isn't my typical SCREEN 0 stuff, but it's close. It uses _NEWIMAGE.

Code: (Select All)

'handle& = _NEWIMAGE(800, 600, 256)
'SCREEN handle&

handle& = _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT, 256)
SCREEN handle&
_SCREENMOVE 0, 0
_DELAY .1
sw = _WIDTH
sh = _HEIGHT

x$ = "Fourscore and seven years ago our fathers brought forth, on this continent, a new nation, conceived in liberty, and dedicated to the proposition that all men are created equal. Now we are engaged in a great civil war, testing whether that nation, or any nation so conceived, and so dedicated, can long endure. We are met on a great battle-field of that war. We have come to dedicate a portion of that field, as a final resting-place for those who here gave their lives, that that nation might live."
fs = 16

GOSUB getfonts

GOSUB getmaxchrs

seed = 1
DO
    x1$ = MID$(x$, seed, noc)
    chop = INSTR(MID$(x$ + " ", seed, noc), " ")
    IF MID$(x$ + " ", seed + noc, 1) = " " OR chop = 0 THEN
        PRINT MID$(x$, seed, noc);
        IF chop = 0 THEN seed = seed + noc ELSE seed = seed + noc + 1
    ELSE
        wrap = _INSTRREV(MID$(x$ + " ", seed, noc), " ")
        PRINT MID$(x$, seed, wrap - 1);
        seed = seed + wrap
    END IF
    IF seed >= LEN(x$) THEN EXIT DO ELSE yy = yy + 1: LOCATE yy + 1, 1
LOOP
b$ = INKEY$: SLEEP
SYSTEM

getfonts:
DO
    fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf" 'Find Windows Folder Path.
    font& = _LOADFONT(fontpath$, fs, "monospace")
    _FONT font&
    w1 = _FONTWIDTH
    h1 = _FONTHEIGHT
    nor = sh \ h1
    noc = sw \ w1
    maxchr = nor * noc
    IF flag THEN EXIT DO
    IF LEN(x$) >= maxchr - noc THEN fs = fs - 1: EXIT DO
    fs = fs + 1
LOOP
fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf" 'Find Windows Folder Path.
font& = _LOADFONT(fontpath$, fs, "monospace")
_FONT font&
RETURN

getmaxchrs:
DO
    seed = 1: prow = 0
    DO
        x1$ = MID$(x$, seed, noc)
        chop = INSTR(MID$(x$ + " ", seed, noc), " ")
        IF MID$(x$ + " ", seed + noc, 1) = " " OR chop = 0 THEN
            prow = prow + 1
            IF chop = 0 THEN seed = seed + noc ELSE seed = seed + noc + 1
        ELSE
            wrap = _INSTRREV(MID$(x$ + " ", seed, noc), " ")
            seed = seed + wrap
            prow = prow + 1
        END IF
    LOOP UNTIL seed >= LEN(x$)

    IF prow <= nor THEN EXIT DO
    prow = 0
    fs = fs - 1
    IF fs = 0 THEN BEEP: END ' ERROR.
    flag = 1: GOSUB getfonts: flag = 0
LOOP
RETURN

Pete