Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
03-25-2025, 04:54 PM
(This post was last modified: 03-25-2025, 05:17 PM by madscijr.
Edit Reason: turns out that unused code wasn't unused, so i put it back!
)
Here's what I have so far, for printing text in a big font.
Then to smoothly scroll, I'd have to redraw slightly shifted over.
Is there a better way to do this?
I'm not crazy about this relying on an array or drawing a rectangle for every pixel, it seems like it could be easier and more efficient.
I vaguely recall seeing different examples of printing a bigger font and smoothly scrolling big text to a hires screen, but can't seem to find them.
Code: (Select All) Dim in$
Dim iChar As Integer
Dim sChar$
Dim iStartX As Integer
Dim x%, y%
Dim fgColor~&
Dim bgColor~&
Dim scale%
ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
GetBigFont arrAlpha()
imgScreen& = _NewImage(1024, 768, 32)
Screen imgScreen&: _ScreenMove 0, 0: Cls , _RGB32(0, 0, 0)
iStartX = 100
bgColor~& = _RGB32(0, 0, 0)
x% = iStartX: y% = 75
scale% = 2: in$ = "Hi": fgColor~& = _RGB32(255, 0, 0)
PrintBigText imgScreen&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
x% = x% + (Len(in$) * _FontWidth * scale%): y% = 75
scale% = scale% + 1: in$ = "how": fgColor~& = _RGB32(255, 255, 0)
PrintBigText imgScreen&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
x% = x% + (Len(in$) * _FontWidth * scale%): y% = 75
scale% = scale% + 1: in$ = "are": fgColor~& = _RGB32(0, 255, 0)
PrintBigText imgScreen&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
x% = x% + (Len(in$) * _FontWidth * scale%): y% = 75
scale% = scale% + 1: in$ = "you": fgColor~& = _RGB32(0, 255, 255)
PrintBigText imgScreen&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
x% = x% + (Len(in$) * _FontWidth * scale%): y% = 75
scale% = scale% + 1: in$ = "??": fgColor~& = _RGB32(0, 0, 255)
PrintBigText imgScreen&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
Color _RGB32(0, 255, 255), _RGB32(0, 0, 0)
_PrintString (1, _Height(imgScreen&) - _FontHeight), "Press any key to exit."
Sleep
Screen 0: Cls: Print "Finished"
If imgScreen& < -1 Or imgScreen& > 0 Then _FreeImage imgScreen&
End
' /////////////////////////////////////////////////////////////////////////////
Sub PrintBigText (imgDest&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim sChar$
Dim x1%, y1%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(in$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
x1% = x%: y1% = y%
For iChar = 1 To Len(in$)
sChar$ = Mid$(in$, iChar, 1)
PrintBigChar imgDest&, sChar$, x1%, y1%, fgColor~&, bgColor~&, scale%, arrAlpha()
x1% = x1% + (_FontWidth * scale%) ' move forward 1 character
Next iChar
End If
End If
End If
End Sub ' PrintBigText
' /////////////////////////////////////////////////////////////////////////////
' Usage:
' PrintBigChar imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
Sub PrintBigChar (imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim x1%, y1%, x2%, y2%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(sChar$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
' Make sure ASCII code is in the range of our array
iChar = Asc(Left$(sChar$, 1))
If (iChar >= LBound(arrAlpha, 1)) And (iChar <= UBound(arrAlpha, 1)) Then
' Print sChar$ as big letter at x%, y% in color fg~&, bg~&
y1% = y%
For sy = 1 To _FontHeight
x1% = x% ' start each line at beginning
y2% = y1% + (scale% - 1) ' calculate y endpoint
For sx = 1 To _FontWidth
x2% = x1% + (scale% - 1) ' calculate x endpoint
If arrAlpha(iChar, sx, sy) = _TRUE Then
Line (x1%, y1%)-(x2%, y2%), fgColor~&, BF
Else
Line (x1%, y1%)-(x2%, y2%), bgColor~&, BF
End If
x1% = x1% + scale% ' move x over by scale%
Next sx
y1% = y1% + scale% ' move y down by scale%
Next sy
End If
End If
End If
End If
End Sub ' PrintBigChar
' /////////////////////////////////////////////////////////////////////////////
Sub GetBigFont (arrAlpha() As Integer)
Dim imgChar As Long
Dim iChar As Integer
Dim sx, sy As Integer
Dim c~&
Dim r As Integer
ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
InitImage imgChar, _FontWidth, _FontHeight, _RGB32(0, 0, 0)
For iChar = 32 To 127
_Dest imgChar
_Source imgChar
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
_PrintString (0, 0), Chr$(iChar)
For sy = 0 To (_FontHeight - 1)
For sx = 0 To (_FontWidth - 1)
c~& = Point(sx, sy)
r = _Red32(c~&): ' g = _Green32(c~&) : b = _Blue32(c~&) : a = _Alpha32(c~&)
If r = 255 Then
arrAlpha(iChar, sx + 1, sy + 1) = _TRUE
Else
arrAlpha(iChar, sx + 1, sy + 1) = _FALSE
End If
Next sx
Next sy
Next iChar
If imgChar< -1 Or imgChar > 0 Then _FreeImage imgChar
End Sub ' GetBigFont
' /////////////////////////////////////////////////////////////////////////////
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' /////////////////////////////////////////////////////////////////////////////
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
Posts: 2,895
Threads: 341
Joined: Apr 2022
Reputation:
261
Isn't this the easiest example of something like this that you're talking about?
Code: (Select All)
DisplayScreen = _NewImage(1280, 720, 32)
Screen DisplayScreen
ScaleScreen = _NewImage(_Width / 4, _Height / 4, 32)
_Dest ScaleScreen 'set _DEST to print to the smaller screen which we want to upscale
'Screen ScaleScreen
Do
junk = junk + 1
Print "Hello World #" + Str$(junk) + " ";
'do whatever else we want. Falalalala
_PutImage , ScaleScreen, DisplayScreen 'put the scaled text to the screen
_Display 'prevent flickers
_Limit 30 'play nice with CPU usage
Loop Until _KeyHit
System
Posts: 4,121
Threads: 188
Joined: Apr 2022
Reputation:
247
@madscijr I am confused what you want, the title says scroll but your demo shows text at different sizes in one row, so you aren't showing any scroll.
I will offer this as potential help:
Code: (Select All) _Title "Text and Text8 tests" ' b+ 2024-11-01
Screen _NewImage(1024, 600, 32): _ScreenMove 0, 0
Color &HFFDDDDFF, &HFF000066: Cls
size = 64
For i = 1 To 20
Text8 20, row, size, &HFF00FF88, "This is line" + Str$(i)
row = row + size + 1
size = 64 * .9 ^ i
Next
row = _Height - 64 - 8
size = 64
For i = 20 To 1 Step -1
t$ = "This is line" + Str$(i)
Text _Width - Len(t$) * size / 2 - 20, row, size, &HFFFF8800, "This is line" + Str$(i)
size = 64 * .9 ^ (21 - i)
row = row - size - 1
Next
_PrintString (350, _Height - 20), "OK tests done."
Sleep
Sub Text8 (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, bg As _Unsigned Long, cur&, i&, f&
fg = _DefaultColor: bg = _BackgroundColor: cur& = _Dest: f& = _Font
i& = _NewImage(8 * Len(txt$), 8, 32)
_Dest i&: _Font 8: Color K, _RGBA32(0, 0, 0, 0): _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&: _Font f&
End Sub
Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, bg As _Unsigned Long, cur&, i&
fg = _DefaultColor: bg = _BackgroundColor: cur& = _Dest
i& = _NewImage(8 * Len(txt$), 16, 32)
_Dest i&: Color K, _RGBA32(0, 0, 0, 0): _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&
End Sub
Text at different sizes on same page, how to determine where next row fits?
b = b + ...
Posts: 88
Threads: 3
Joined: Apr 2022
Reputation:
17
Or do you mean something like that?
I just found it in the collection , It's from B+
Code: (Select All)
_Title "Scale rotate font text strings." 'B+ started
' The following CONSTants or TYPES are for the demo and NOT needed for the 2 main subs
Randomize Timer
Const xmax = 1200
Const ymax = 700
Const x0 = 600
Const y0 = 350
Const radius = 240
Const r2 = 20
Dim Shared fv72& ' testing verdanab.ttf
fv72& = _LoadFont("verdanab.ttf", 72)
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
''test font load
'_FONT fv72&
'S$ = "helloworld pdq"
'PRINT S$, _PRINTWIDTH(S$), _FONTHEIGHT(fv72&)
'LINE (0, 0)-STEP(_PRINTWIDTH(S$), _FONTHEIGHT(fv72&)), , B
'END
a = 1: dir = 1: dir2 = 1: runner = 0
ca = _Pi(2 / 20)
t$ = "Scale and rotate text strings"
While _KeyDown(27) = 0
Color , _RGB32(runner Mod 255, runner Mod 255, 128)
Cls
''this demos stretching and shrinking the xScale while the text string is turned + and - Pi/2 or 90 degrees
'left side red
drwString t$, &HFF992200, 300, ymax / 2, 10 * Abs(rot), .5, _Pi(-.5)
''right side green
drwString t$, &HFF008800, xmax - 300, ymax / 2, 10 * Abs(rot), .5, _Pi(.5)
''this demos rotaing a text string about the x axis at 3 times default font scale, rot range -1 to 1
drwString t$, &HFF0000FF, xmax / 2, 32, 1, 1 * rot, 0
''this demos rotaing a text string about the y axis at 3 times default font scale, rot range -1 to 1
drwString t$, &HFF00FF00, xmax / 2, ymax - 32, 1 * rot, 1, 0
''this demos rotating a text string from 0 to 2 Pi radians and reverse 0 to -2 Pi
''and shrinking both the xScale and yScale at same time and amount
drwString t$, &HFFFF0066, xmax / 2, ymax / 2, Abs(rot) * 2, Abs(rot) * 2, a
'this demos moving .5 sized numbers around a circle angled so the circle is the bottom of number
Circle (x0, y0), radius
For i = 0 To 19
x = x0 + (radius + 18) * Cos(ca * i - 4.5 * ca)
y = y0 + (radius + 18) * Sin(ca * i - 4.5 * ca)
s = (i + runner) Mod 20
drwString _Trim$(Str$(s)), &HFFFFFFFF, x, y, .5, .5, ca * i - 4.5 * ca + _Pi(.5)
Next
Print "Hello Default Font."
runner = runner + 1
rot = rot + .025 * dir
If rot > 1 Then dir = -dir: rot = 1
If rot < -1 Then dir = -dir: rot = -1
a = a + _Pi(1 / 45) * dir2
If a > _Pi(2) Then dir2 = -dir2: a = _Pi(2)
If a < _Pi(-2) Then dir2 = -dir2: a = _Pi(-2)
_Display
_Limit 5
Wend
'drwString needs sub RotoZoom2, intended for graphics screens using the default font.
'S$ is the string to display
'c is the color (will have a transparent background)
'midX and midY is the center of where you want to display the string
'xScale would multiply 8 pixel width of default font
'yScale would multiply the 16 pixel height of the default font
'Rotation is in Radian units, use _D2R to convert Degree units to Radian units
Sub drwString (S$, c As _Unsigned Long, midX, midY, xScale, yScale, Rotation)
storeFont& = _Font
storeDest& = _Dest
_Font fv72& ' loadfont at start and share handle
I& = _NewImage(_PrintWidth(S$), _FontHeight(fv72&), 32)
_Dest I&
_Font fv72&
Color c, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), S$
_Dest storeDest&
RotoZoom2 midX, midY, I&, xScale, yScale, Rotation
_FreeImage I&
_Font storeFont&
End Sub
'This sub gives really nice control over displaying an Image.
Sub RotoZoom2 (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
Dim px(3) As Single: Dim py(3) As Single
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-Rotation): cosr! = Cos(-Rotation)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
03-25-2025, 07:09 PM
(This post was last modified: 03-25-2025, 07:34 PM by madscijr.
Edit Reason: fixed something else
)
Wow, thanks guys. Sorry about not being clear - by scrolling I meant horizontally scrolling marquee text.
I'll check out your code to make the font bigger (I'm sure those will be a big improvement on what I came up with).
Here's my finished example which shows what I was going for, that there has to be a better way to do...
Thanks again
Code: (Select All) Dim in$
Dim iChar As Integer
Dim sChar$
Dim iStartX As Integer
Dim x%, y%
Dim fgColor~&
Dim bgColor~&
Dim scale%
Dim iColor As Integer
Dim iWord As Integer
Dim iSize As Integer
Dim iSpeed As Integer
Dim bFinished As Integer
Dim iExtraSpace%
Dim iEscColor As Integer
Dim iEscFlash As Integer
Dim iStartColor As Integer
ReDim arrColor(-1) As _Unsigned Long
ReDim arrAlpha(0, 0, 0) As Integer
ReDim arrText(0) As String
GetColorArray arrColor()
GetBigFont arrAlpha()
InitImage imgScreen&, 1024, 768, _RGB32(0, 0, 0)
Screen imgScreen&: _ScreenMove 0, 0
Color _RGB32(255, 255, 0), _RGB32(0, 0, 0)
Locate 1, 1: Print "Scrolling big text"
Color _RGB32(192, 192, 192), _RGB32(0, 0, 0)
Locate 1, 20: Print "(Poetry by Douglas Adams)"
in$ = Chr$(34) + "Oh freddled gruntbuggly, Thy micturitions are to me, As plurdled gabbleblotchits, On a lurgid bee." + Chr$(34) + " - Prostetnic Vogon Jeltz" + " ."
split in$, " ", arrText()
bgColor~& = _RGB32(0, 0, 0)
scale% = 2: y% = 125
iSpeed = 0 - ((_FontWidth * scale%) / 3)
bFinished = _FALSE
iEscFlash = 4
iEscColor = 128
iStartColor = LBound(arrColor)
Do
' Recalculate how many space iterations needed to fully scroll text off screen
iExtraSpace% = _Width(imgScreen&) / (_FontWidth * scale%)
arrText(UBound(arrText)) = String$(iExtraSpace%, " ")
' Recalculate how far loop goes to scroll whole message
iSize = (Len(in$) + iExtraSpace%) * _FontWidth * scale%
iSize = iSize + (_Width(imgScreen&) / (_FontWidth * scale%))
iSize = 0 - iSize
For iStartX = 1 To iSize Step iSpeed
Color _RGB32(0, 255, 255), _RGB32(0, 0, 0)
Locate 3, 1: Print "For iStartX = 1 To iSize Step iSpeed"
Locate 4, 1: Print "For iStartX = 1 To " + _Trim$(Str$(iSize)) + " Step " + _Trim$(Str$(iSpeed))
Locate 5, 1: Print " iStartX = " + _Trim$(Str$(iStartX))
'Color _RGB32(160, 160, 160), _RGB32(0, 0, 0)
'Locate 6, 1: Print "iExtraSpace%= " + _Trim$(Str$(iExtraSpace%))
iEscColor = iEscColor + iEscFlash
If iEscColor > 255 Then
iEscColor = 255
iEscFlash = 0 - iEscFlash
ElseIf iEscColor < 64 Then
iEscColor = 64
iEscFlash = 0 - iEscFlash
End If
Color _RGB32(iEscColor, iEscColor, iEscColor), _RGB32(0, 0, 0)
Locate 7, 1: Print "Press Esc to quit"
x% = iStartX + _Width(imgScreen&)
iColor = iStartColor
For iWord = LBound(arrText) To UBound(arrText)
' PRINT NEXT WORD
fgColor~& = arrColor(iColor)
PrintBigText imgScreen&, arrText(iWord) + " ", x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
' MOVE IT ON OVER
x% = x% + (Len(arrText(iWord)) + 1) * _FontWidth * scale%
' COLOR NEXT WORD
iColor = iColor + 1: If iColor > UBound(arrColor) Then iColor = LBound(arrColor)
Next iWord
If _KeyHit = -27 Then bFinished = _TRUE: Exit For
_Limit 60
Next iStartX
If bFinished = _TRUE Then Exit Do
' Increase font size upto half the screen height then restart at x2
scale% = scale% + 1
If (_FontHeight * scale%) <= (_Height(imgScreen&) / 2) Then
' Recalculate speed for new text size
iSpeed = iSpeed - 1
Else
scale% = 2
iSpeed = 0 - ((_FontWidth * scale%) / 3)
End If
iStartColor = iStartColor + 1: If iStartColor > UBound(arrColor) Then iStartColor = LBound(arrColor)
Loop
Color _RGB32(0, 255, 255), _RGB32(0, 0, 0)
_PrintString (1, _Height(imgScreen&) - _FontHeight), "Press any key to exit."
Sleep
Screen 0: Cls: Print "Finished"
If imgScreen& < -1 Or imgScreen& > 0 Then _FreeImage imgScreen&
End
' /////////////////////////////////////////////////////////////////////////////
Sub PrintBigText (imgDest&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim sChar$
Dim x1%, y1%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(in$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
x1% = x%: y1% = y%
For iChar = 1 To Len(in$)
sChar$ = Mid$(in$, iChar, 1)
PrintBigChar imgDest&, sChar$, x1%, y1%, fgColor~&, bgColor~&, scale%, arrAlpha()
x1% = x1% + (_FontWidth * scale%) ' move forward 1 character
Next iChar
End If
End If
End If
End Sub ' PrintBigText
' /////////////////////////////////////////////////////////////////////////////
' Usage:
' PrintBigChar imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
Sub PrintBigChar (imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim x1%, y1%, x2%, y2%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(sChar$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
' Make sure ASCII code is in the range of our array
iChar = Asc(Left$(sChar$, 1))
If (iChar >= LBound(arrAlpha, 1)) And (iChar <= UBound(arrAlpha, 1)) Then
' Print sChar$ as big letter at x%, y% in color fg~&, bg~&
y1% = y%
For sy = 1 To _FontHeight
x1% = x% ' start each line at beginning
y2% = y1% + (scale% - 1) ' calculate y endpoint
For sx = 1 To _FontWidth
x2% = x1% + (scale% - 1) ' calculate x endpoint
If arrAlpha(iChar, sx, sy) = _TRUE Then
Line (x1%, y1%)-(x2%, y2%), fgColor~&, BF
Else
Line (x1%, y1%)-(x2%, y2%), bgColor~&, BF
End If
x1% = x1% + scale% ' move x over by scale%
Next sx
y1% = y1% + scale% ' move y down by scale%
Next sy
End If
End If
End If
End If
End Sub ' PrintBigChar
' /////////////////////////////////////////////////////////////////////////////
' arrAlpha should be ReDimmed and not Dimmed before calling, e.g.,
' ReDim arrAlpha(0, 0, 0) As Integer
' GetBigFont arrAlpha()
Sub GetBigFont (arrAlpha() As Integer)
Dim imgChar As Long
Dim iChar As Integer
Dim sx, sy As Integer
Dim c~&
Dim r As Integer
ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
InitImage imgChar, _FontWidth, _FontHeight, _RGB32(0, 0, 0)
For iChar = 32 To 127
_Dest imgChar
_Source imgChar
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
_PrintString (0, 0), Chr$(iChar)
For sy = 0 To (_FontHeight - 1)
For sx = 0 To (_FontWidth - 1)
c~& = Point(sx, sy)
r = _Red32(c~&): ' g = _Green32(c~&) : b = _Blue32(c~&) : a = _Alpha32(c~&)
If r = 255 Then
arrAlpha(iChar, sx + 1, sy + 1) = _TRUE
Else
arrAlpha(iChar, sx + 1, sy + 1) = _FALSE
End If
Next sx
Next sy
Next iChar
If imgChar < -1 Or imgChar > 0 Then _FreeImage imgChar
End Sub ' GetBigFont
' /////////////////////////////////////////////////////////////////////////////
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' /////////////////////////////////////////////////////////////////////////////
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor
' /////////////////////////////////////////////////////////////////////////////
'Sub AddColors (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long, HowMany As Long)
' Dim iLoop As Integer
' For iLoop = 1 To HowMany
' AddColor ColorValue, arrColor()
' Next iLoop
'End Sub ' AddColors
' /////////////////////////////////////////////////////////////////////////////
' arrColor Should be redimmed and not dimmed before calling, e.g.,
' Redim arrColor(-1) : GetColorArray arrColor()
Sub GetColorArray (arrColor() As _Unsigned Long)
'Dim iNum As Integer
'iNum = 1
AddColor _RGB32(255, 0, 0), arrColor() ', iNum
AddColor _RGB32(255, 69, 0), arrColor() ', iNum
AddColor _RGB32(255, 255, 0), arrColor() ', iNum
AddColor _RGB32(0, 255, 0), arrColor() ', iNum
AddColor _RGB32(0, 255, 255), arrColor() ', iNum
AddColor _RGB32(0, 0, 255), arrColor() ', iNum
AddColor _RGB32(128, 0, 255), arrColor() ', iNum
End Sub ' GetColorArray
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
Posts: 4,121
Threads: 188
Joined: Apr 2022
Reputation:
247
Nice!
Here is my lecture on that subject:
Code: (Select All) _Title "Building a Scrolling LED Screen" ' b+ 2021-05-08
Screen _NewImage(1200, 160, 32)
_Delay .25 'give screen time to load
_ScreenMove _Middle 'and center screen
'scroll some text
Text$ = "Try scrolling me for awhile until you got it, then press a key... "
lenText = Len(Text$)
startTextPos = 1
'put text in sign 15 chars wide in middle of screen print the message moving down 1 character evey frame
_Title "Building a Scrolling LED Screen: Step 1 get some code to scroll your message in middle of screen."
Do
k$ = InKey$
Cls
' two pieces of text? when get to end of text will have less than 15 chars to fill sign so get remainder from front
len1 = lenText - startTextPos
If len1 < 15 Then len2 = 15 - len1 Else len1 = 15: len2 = 0
' locate at middle of screen for 15 char long sign
_PrintString ((1200 - 15 * 8) / 2, (160 / 2) - 8), Mid$(Text$, startTextPos, len1) + Mid$(Text$, 1, len2)
startTextPos = startTextPos + 1
If startTextPos > lenText Then startTextPos = 1
_Display ' no blinking when clear screen so often
_Limit 5 ' slow down to see scroll
Loop Until Len(k$)
' OK now for the enLARGE M E N T using _PutImage
' our little sign is 16 pixels high and 8 * 15 chars pixels wide = 120
Dim sign As Long
sign = _NewImage(120, 16, 32) ' we will store the print image here
' _PUTIMAGE [STEP] [(dx1, dy1)-[STEP][(dx2, dy2)]][, sourceHandle&][, destHandle&][, ][STEP][(sx1, sy1)[-STEP][(sx2, sy2)]][_SMOOTH]
' use same pixel location to _printString as for _PutImage Source rectangle ie (sx1, sy1), -step( sign width and height)
' test screen capture with _putimage and then blowup with _putimage
'_PutImage , 0, sign, ((1200 - 15 * 8) / 2, (160 / 2) - 8)-Step(119, 15)
'Cls
'_PutImage , sign, 0 ' stretch to whole screen
'_Display
'now that that works do it on the move
' about here I resized the screen to 1200 x 160 to make the text scalable X's 10 ie 120 x 10 wide and 16 x 10 high
_Title "Building a Scrolling LED Screen: Step 2 Blow it up by using _PutImage twice once to capture, then to expand"
k$ = ""
Do
k$ = InKey$
Cls
' two pieces of text? when get to end of text will have less than 15 chars to fill sign so get remainder from front
len1 = lenText - startTextPos
If len1 < 15 Then len2 = 15 - len1 Else len1 = 15: len2 = 0
' locate at middle of screen for 15 char long sign
_PrintString ((1200 - 15 * 8) / 2, (160 / 2) - 8), Mid$(Text$, startTextPos, len1) + Mid$(Text$, 1, len2)
_PutImage , 0, sign, ((1200 - 15 * 8) / 2, (160 / 2) - 8)-Step(119, 15)
Cls
_PutImage , sign, 0 ' stretch to whole screen
_Display ' no blinking when clear screen so often
_Limit 5 ' slow down to see scroll
startTextPos = startTextPos + 1
If startTextPos > lenText Then startTextPos = 1
Loop Until Len(k$)
' now for a mask just draw a grid test grid draw here
'For x = 0 To _Width Step 10 ' verticals
' Line (x, 0)-(x + 3, _Height), &HFF000000, BF
'Next
'For y = 0 To _Height Step 10
' Line (0, y)-(_Width, y + 3), &HFF000000, BF
'Next
_Title "Building a Scrolling LED Screen: Step 3 Mask or Cover the thing with a grid or grate."
' here is the whole code with all setup variables
k$ = ""
Do
k$ = InKey$
Cls
' two pieces of text? when get to end of text will have less than 15 chars to fill sign so get remainder from front
len1 = lenText - startTextPos
If len1 < 15 Then len2 = 15 - len1 Else len1 = 15: len2 = 0
' locate at middle of screen for 15 char long sign
_PrintString ((1200 - 15 * 8) / 2, (160 / 2) - 8), Mid$(Text$, startTextPos, len1) + Mid$(Text$, 1, len2)
_PutImage , 0, sign, ((1200 - 15 * 8) / 2, (160 / 2) - 8)-Step(119, 15)
Cls
_PutImage , sign, 0 ' stretch to whole screen
' now for a mask just draw a grid best to draw this and copy and layover screen as another layer
' here QB64 is fast evough to redarw each time
For x = 0 To _Width Step 10 ' verticals
Line (x, 0)-(x + 3, _Height), &HFF000000, BF
Next
For y = 0 To _Height Step 10
Line (0, y)-(_Width, y + 3), &HFF000000, BF
Next
_Display ' no blinking when clear screen so often
_Limit 5 ' slow down to see scroll
startTextPos = startTextPos + 1
If startTextPos > lenText Then startTextPos = 1
Loop Until Len(k$)
b = b + ...
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
Thanks @bplus, i'll give that a look.
Right away I see you are stretching the font with _PutImage, which would save me from having to use an array, but I'm getting an illegal function call.
I'm out of time for today but can keep plugging away on it later.
Thanks for posting that, I'll re-read it later.
Code: (Select All) ' display "hello" 2x bigger on screen
Dim img1 As Long
Dim ing2 As Long
Dim in2$
in2$ = "hello"
InitImage img1, _FontWidth * Len(in2$), _FontHeight, _RGB32(0, 0, 0)
InitImage img2, 1024, 768, _RGB32(0, 0, 0)
_Dest img1
Locate 1, 1
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
Print "hello"
Screen img2: _ScreenMove 0, 0
_Dest img2
Dim sx1 As Integer, sy1 As Integer, sx2 As Integer, sy2 As Integer
sx1 = 1
sy1 = 1
sx2 = _Width(img1)
sy2 = _Height(img1)
Dim dx1 As Integer, dy1 As Integer, dx2 As Integer, dy2 As Integer
dx1 = 10
dy1 = 20
dx2 = _FontWidth * Len(in2$) * 2
dy2 = _FontHeight * 2
'_PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&, (sx1, sy1) ' right side of source from top-left corner to destination
'THIS LINE FAILS WITH ILLEGAL FUNCTION CALL ERROR:
_PutImage (dx1, dy1)-(dx2, dy2), img1, img2, (sx1, sy1) '-(sx2, sy2)
Sleep
Screen 0
FreeImage img1
FreeImage img2
' /////////////////////////////////////////////////////////////////////////////
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' _PUTIMAGE - QB64 Phoenix Edition Wiki
' https://qb64phoenix.com/qb64wiki/index.php/PUTIMAGE
' _PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&,(sx1, sy1) 'right side of source from top-left corner to destination
' DAY 009:_PutImage
' https://qb64phoenix.com/forum/showthread.php?pid=9827
Posts: 339
Threads: 53
Joined: May 2022
Reputation:
43
My quick little thing - use _PutImage to enlarge the text, if you use a font other than MonoSpace, you will have to set the height and width of the font yourself according to the given font size (by estimation or calculation or otherwise), you can also zoom in on each character extra, but here I would really solve it with an array. Use the mouse wheel in the program, it's just a quick code that is far from perfect.
Code: (Select All)
font = _LoadFont("arial.ttf", 40, "monospace")
text$ = "test"
virtual = _NewImage(_FontWidth(font) * Len(text), _FontHeight(font), 32)
_Font font, virtual
_PrintString (0, 0), text$, virtual
Screen _NewImage(1080, 1050, 32)
Do Until I$ = Chr$(27)
I$ = InKey$
Do While _MouseInput
zoom = zoom + _MouseWheel / 10
Loop
Cls
Z virtual, _MouseX, _MouseY, zoom
_Display
_Limit 20
Loop
Sub Z (image, x, y, zoom)
w = _Width(image)
h = _Height(image)
_PutImage (x, y)-(x + w * zoom, y + w * zoom), image, 0
End Sub
Posts: 4,121
Threads: 188
Joined: Apr 2022
Reputation:
247
(03-25-2025, 08:31 PM)madscijr Wrote: Thanks @bplus, i'll give that a look.
Right away I see you are stretching the font with _PutImage, which would save me from having to use an array, but I'm getting an illegal function call.
I'm out of time for today but can keep plugging away on it later.
Thanks for posting that, I'll re-read it later.
Code: (Select All) ' display "hello" 2x bigger on screen
Dim img1 As Long
Dim ing2 As Long
Dim in2$
in2$ = "hello"
InitImage img1, _FontWidth * Len(in2$), _FontHeight, _RGB32(0, 0, 0)
InitImage img2, 1024, 768, _RGB32(0, 0, 0)
_Dest img1
Locate 1, 1
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
Print "hello"
Screen img2: _ScreenMove 0, 0
_Dest img2
Dim sx1 As Integer, sy1 As Integer, sx2 As Integer, sy2 As Integer
sx1 = 1
sy1 = 1
sx2 = _Width(img1)
sy2 = _Height(img1)
Dim dx1 As Integer, dy1 As Integer, dx2 As Integer, dy2 As Integer
dx1 = 10
dy1 = 20
dx2 = _FontWidth * Len(in2$) * 2
dy2 = _FontHeight * 2
'_PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&, (sx1, sy1) ' right side of source from top-left corner to destination
'THIS LINE FAILS WITH ILLEGAL FUNCTION CALL ERROR:
_PutImage (dx1, dy1)-(dx2, dy2), img1, img2, (sx1, sy1) '-(sx2, sy2)
Sleep
Screen 0
FreeImage img1
FreeImage img2
' /////////////////////////////////////////////////////////////////////////////
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' _PUTIMAGE - QB64 Phoenix Edition Wiki
' https://qb64phoenix.com/qb64wiki/index.php/PUTIMAGE
' _PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&,(sx1, sy1) 'right side of source from top-left corner to destination
' DAY 009:_PutImage
' https://qb64phoenix.com/forum/showthread.php?pid=9827
Typo on line: Dim ing2 As Long ' you want img2
No more error just a big ole blank screen 
But I don't what the hell you are doing with all that other stuff? (very confused emoji here)
b = b + ...
Posts: 2,895
Threads: 341
Joined: Apr 2022
Reputation:
261
03-25-2025, 10:47 PM
(This post was last modified: 03-25-2025, 10:51 PM by SMcNeill.)
For this type of quick thing, I have two simple routines to use: TextToImage and ScaleImage
Code: (Select All)
$Color:32
Display = _NewImage(1280, 720, 32)
Screen Display
in$ = Chr$(34) + "Oh freddled gruntbuggly, Thy micturitions are to me, As plurdled gabbleblotchits, On a lurgid bee." + Chr$(34) + " - Prostetnic Vogon Jeltz" + " ."
textImg = TextToImage(in$, 16, Red, Yellow, 1)
i = .25 'inital tiny print
Do
tempImage = ScaleImage(textImg, i, i)
w = _Width(tempImage)
For x = 1280 To 0 - w Step -2
Cls
_PutImage (x, 0), tempImage, Display
_Display
_Limit 120
Next
_FreeImage tempImage
i = i * 2 'double print size every pass
Loop Until i >= 16
System
Function ScaleImage& (Image As Long, xscale As Single, yscale As Single)
w = _Width(Image): h = _Height(Image)
w2 = w * xscale: h2 = h * yscale
NewImage& = _NewImage(w2, h2, 32)
_PutImage , Image&, NewImage&
ScaleImage& = NewImage&
End Function
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
'text$ is the text that we wish to transform into an image.
'font& is the handle of the font we want to use.
'fc& is the color of the font we want to use.
'bfc& is the background color of the font.
'Mode 1 is print forwards
'Mode 2 is print backwards
'Mode 3 is print from top to bottom
'Mode 4 is print from bottom up
'Mode 0 got lost somewhere, but it's OK. We check to see if our mode is < 1 or > 4 and compensate automatically if it is to make it one (default).
If mode < 1 Or mode > 4 Then mode = 1
dc& = _DefaultColor: bgc& = _BackgroundColor
D = _Dest
F = _Font
T2Idown = CsrLin: T2Iright = Pos(0)
If font& <> 0 Then _Font font&
If mode < 3 Then
'print the text lengthwise
w& = _PrintWidth(text$): h& = _FontHeight
Else
'print the text vertically
For i = 1 To Len(text$)
If w& < _PrintWidth(Mid$(text$, i, 1)) Then w& = _PrintWidth(Mid$(text$, i, 1))
Next
h& = _FontHeight * (Len(text$))
End If
TextToImage_temp& = _NewImage(w&, h&, 32)
TextToImage = TextToImage_temp&
_Dest TextToImage_temp&
If font& <> 0 Then _Font font&
Color fc&, bfc&
Select Case mode
Case 1
'Print text forward
_PrintString (0, 0), text$
Case 2
'Print text backwards
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
_PrintString (0, 0), temp$
Case 3
'Print text upwards
'first lets reverse the text, so it's easy to place
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
'then put it where it belongs
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(temp$, i, 1)
Next
Case 4
'Print text downwards
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(text$, i, 1)
Next
End Select
_Dest D
Color dc&, bgc&
_Font F
Locate T2Idown, T2Iright
End Function
Note that ScaleImage may be all the code you actually need, if you're doing the printing on a screen yourself to begin with. (Such as with the multi-colored text.)
Just make the screen _newimage(_fonthight, _printwidth, 32) in size, then print to it in the colors you want...
Scale it to proper size wanted for the scroll.
And then just scroll it from the scaled image.
|
