Posts: 4,121
Threads: 188
Joined: Apr 2022
Reputation:
247
03-25-2025, 11:17 PM
(This post was last modified: 03-25-2025, 11:22 PM by bplus.)
Hello in red on white at 12X's height in the middle of the screen:
Code: (Select All) Screen _NewImage(800, 600, 32): _ScreenMove 250, 60
s$ = " Hello "
ls = Len(s$)
mult = 12
Text (800 - ls * _FontWidth * mult) / 2, (600 - _FontHeight * mult) / 2, mult * _FontHeight, &HFFFF0000, &HFFFFFFFF, s$
Sub Text (x, y, textHeight, fore As _Unsigned Long, back 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 fore, back: _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&
End Sub
b = b + ...
Posts: 586
Threads: 103
Joined: Apr 2022
Reputation:
47
03-25-2025, 11:50 PM
(This post was last modified: 03-25-2025, 11:52 PM by SierraKen.)
That's a great way Bplus! Here is a little scrolling mod I just made using the Mouse Wheel, although I think you have done this before. This also centers the Hello on the screen pretty good.
Code: (Select All)
'Bplus Font Resize - Scrolling Mod by SierraKen
Screen _NewImage(800, 600, 32): _ScreenMove 250, 60
s$ = "Hello"
ls = Len(s$)
size = 1
Do
_Limit 40
While _MouseInput
If _MouseWheel = -1 Then Cls: size = size + 1
If _MouseWheel = 1 Then Cls: size = size - 1
Wend
If size < 1 Then size = 70
If size > 70 Then size = 1
Text ((800 - ls * _FontWidth) / 2) - (size * 20), ((600 - _FontHeight) / 2) - (size * 8), size * _FontHeight, &HFFFF0000, s$
Loop Until InKey$ = Chr$(27)
End
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
Posts: 4,121
Threads: 188
Joined: Apr 2022
Reputation:
247
Posts: 586
Threads: 103
Joined: Apr 2022
Reputation:
47
03-26-2025, 01:01 AM
(This post was last modified: 03-26-2025, 01:03 AM by SierraKen.)
Thanks B+. After I made that, I realized you were replying to someone, I guess my head was in the clouds...
So I decided to make the text side-scroller news that he wanted, with a little story I made up. 
This is using the resized text that Bplus posted.
Code: (Select All)
'Side News Scroller by SierraKen
'Resized text code by Bplus.
Dim s$(19)
Screen _NewImage(800, 600, 32): _ScreenMove 250, 60
ls = Len(s$)
size = 2
t = 1
Read s$(t)
xx = -400
Do
_Limit 40
xx = xx + 4
If xx > 550 Then
t = t + 1
xx = -400
If t = 18 Then Restore story: t = 1
Read s$(t)
End If
Text ((800 - ls * _FontWidth) / 2) - (2 * xx), ((600 - _FontHeight) / 2) - (size * 16), size * _FontHeight, &HFFFF0000, s$(t)
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
End
story:
Data "Hello...","My name is Computer 5000...","Today's weather is Sunny with a breeze of 5 mph from the West..."
Data "Today's news is that everything is a-okay...","Breaking News..."
Data "Martians have landed!...","This may be my last newscast...","Over to you on the field Ralph..."
Data "Yeah it looks bad, Martians have destroyed everything...","Oh wait! Here comes the helicopters!..."
Data "*CRASH BOOM SMACK.... BZZZZZZZZZZZZ*...","Come in Ralph, you there? We seem to have lost the transmission..."
Data "Now over to Henry...","It looks like everything is under control...","The Martians are leaving now..."
Data "I guess they didn't want anything here on Earth...","They said all of our stuff is outdated, so they are leaving the planet..."
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
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
Thanks everyone - I can't wait to run all these when I'm back at the computer!
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
03-26-2025, 08:34 PM
(This post was last modified: 03-26-2025, 11:50 PM by madscijr.)
I checked it all out, some very useful methods. Threw it all into one program with a menu, so I could compare (code below).
I did run into a strange problem - if I ran them in the order they appear on the menu, certain examples would leave QB64PE in a state where certain other examples that ran after no longer seemed to work (even though if you choose them first they do work). Very strange! I thought maybe there was some memory leak, and found several examples didn't have _FreeImage, so I added those (big mistake for a couple of functions that return the image!) Anyway, I finally figured out that there were examples that used _Display but at the end never called _AutoDisplay. DOH! So I added that and now everything works.
I'm going to work in some of these methods and will post my improved scrolling code when it's ready.
Thanks everyone!
Code: (Select All) ' Global vars
ReDim Shared fv72& ' used by subs BigRotatingText4, drwString (for testing verdanab.ttf)
Dim in$
Do
_Title "Big scrolling text demos"
Screen 0: _ScreenMove 0, 0
Cls
Print
Print "Big and/or scrolling text demos:"
Print
Print " 1. BigTextScroll17 by madscijr"
Print " 2. ScrollingLED by bplus"
Print " 3. BigText3 by bplus"
Print " 4. BigRotatingText4 by Steffan-68"
Print " 5. BigText8 by Petr"
Print " 6. BigText0 by madscijr"
Print " 7. BigText11 by bplus"
Print " 8. BigText12 by SierraKen"
Print " 9. ScrollBigText10 by SMcNeill"
Print "10. ScrollBigText14 by SierraKen"
Print
Print "NOTE: if you use _Display remember to do _AutoDisplay at the end! :-)"
Print
Input "Your choice (1-10 or Q to quit) "; in$
in$ = _Trim$(UCase$(in$))
Select Case in$
Case "1": BigTextScroll17
Case "2": ScrollingLED
Case "3": BigText3
Case "4": BigRotatingText4
Case "5": BigText8
Case "6": BigText0
Case "7": BigText11
Case "8": BigText12
Case "9": ScrollBigText10
Case "10": ScrollBigText14
Case "Q": Exit Do
Case Else:
End Select
_KeyClear ' CLEAR KEYBOARD BUFFER
Loop
Print "End of demo."
End
' /////////////////////////////////////////////////////////////////////////////
' scroll big text v0.17 by madscijr
' TODO: make more efficient + simpler
Sub BigTextScroll17
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 Esc to exit."
Do: Loop Until InKey$ = Chr$(27)
'Screen 0: Cls: Print "Finished"
Screen 0
If imgScreen& < -1 Or imgScreen& > 0 Then _FreeImage imgScreen&
End Sub ' BigTextScroll17
' /////////////////////////////////////////////////////////////////////////////
' Prints string in$
' on image imgDest&
' at location (x%, y%)
' in color fgColor~&, bgColor~&
' blown up scale% times
' requires array arrAlpha derived from sub GetBigFont
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
' /////////////////////////////////////////////////////////////////////////////
' Prints a single character sChar$
' on image imgDest&
' at location (x%, y%)
' in color fgColor~&, bgColor~&
' blown up scale% times
' requires array arrAlpha derived from sub GetBigFont
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns an array containing the pixel information for the current font,
' in the form:
' arrAlpha( {character code}, {x pixel}, {y pixel})
' 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
' /////////////////////////////////////////////////////////////////////////////
' display "hello" 2x bigger on screen
' without needing an array
' finally works, yay!
' _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
Sub BigText0
Dim sourceHandle&
Dim destHandle&
Dim in$
Dim dx1 As Integer, dy1 As Integer, dx2 As Integer, dy2 As Integer
Dim iWidth&, iHeight&
Cls: Print "please wait"
'_Display
in$ = "hello"
iWidth& = _FontWidth * Len(in$)
iHeight& = _FontHeight
InitImage sourceHandle&, iWidth&, iHeight&, _RGB32(0, 0, 0)
'InitImage sourceHandle&, 40, 16, _RGB32(0, 0, 0)
'_Dest sourceHandle&
Screen sourceHandle&: _ScreenMove 0, 0
Locate 1, 1
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
Print in$;
'_Dest 0
'Print "iWidth&=" + _Trim$(Str$(iWidth&))
'Print "iHeight&=" + _Trim$(Str$(iHeight&))
'Sleep
InitImage destHandle&, 1024, 768, _RGB32(0, 0, 0)
Screen destHandle&: _ScreenMove 0, 0
_Dest destHandle&
dx1 = 50
dy1 = 90
dx2 = dx1 + ((iWidth& * 2) - 1)
dy2 = dy1 + ((iHeight& * 2) - 1)
' size full source to destination coordinate area
_PutImage (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&
Locate 20, 1: Print "Press Esc to continue"
Do: Loop Until InKey$ = Chr$(27)
Screen 0
FreeImage sourceHandle&
FreeImage destHandle&
End Sub ' BigText0
' /////////////////////////////////////////////////////////////////////////////
' Initializes an image
' (if it already exists, frees it up and re-instantiates)
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
' Frees image if it exists
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns 100% transparent RGB color
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' /////////////////////////////////////////////////////////////////////////////
' Used by sub GetColorArray
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
' /////////////////////////////////////////////////////////////////////////////
' arrColor Should be redimmed and not dimmed before calling, e.g.,
' Redim arrColor(-1) : GetColorArray arrColor()
Sub GetColorArray (arrColor() As _Unsigned Long)
ReDim arrColor(-1) As _Unsigned Long
AddColor _RGB32(255, 0, 0), arrColor()
AddColor _RGB32(255, 69, 0), arrColor()
AddColor _RGB32(255, 255, 0), arrColor()
AddColor _RGB32(0, 255, 0), arrColor()
AddColor _RGB32(0, 255, 255), arrColor()
AddColor _RGB32(0, 0, 255), arrColor()
AddColor _RGB32(128, 0, 255), arrColor()
End Sub ' GetColorArray
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #2
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32954#pid32954
' From: bplus, Mini-Mod
' Date: 3/25/2025 03:59 PM
'
' Nice!
'
' Here is my lecture on that subject:
' Building a Scrolling LED Screen by b+ 2021-05-08
' https://staging.qb64phoenix.com/showthread.php?tid=1693&pid=16764#pid16764
Sub ScrollingLED
_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
_ScreenMove 0, 0
' 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$)
_AutoDisplay
Screen 0
If sign < -1 Or sign > 0 Then _FreeImage sign
End Sub ' ScrollingLED
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #3
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32955#pid32955
' From: bplus, Mini-Mod
' Date: 3/25/2025 01:51 PM
' [url=https://qb64phoenix.com/forum/member.php?action=profile&uid=10]@madscijr[/url] 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:
Sub BigText3
_Title "Text1 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 i
row = _Height - 64 - 8
size = 64
For i = 20 To 1 Step -1
t$ = "This is line" + Str$(i)
Text1 _Width - Len(t$) * size / 2 - 20, row, size, &HFFFF8800, "This is line" + Str$(i)
size = 64 * .9 ^ (21 - i)
row = row - size - 1
Next i
_PrintString (350, _Height - 20), "OK tests done. Press Esc to exit."
Do: Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText3
' /////////////////////////////////////////////////////////////////////////////
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 ' Text8
' /////////////////////////////////////////////////////////////////////////////
Sub Text1 (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 ' Text1
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #12
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32969#pid32969
' From: SierraKen, Mini-Mod
' Date: 3/25/2025 07:50 PM (This post was last modified: Yesterday, 07:52 PM by SierraKen.)
' That's a great way Bplus! Here is a little scrolling mod I just made using the
' Mouse Wheel, although I think you have done this before. This also centers the
' Hello on the screen pretty good.
' Bplus Font Resize - Scrolling Mod by SierraKen
Sub BigText12
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
_ScreenMove 0, 0
s$ = "Hello"
ls = Len(s$)
size = 1
Do
_Limit 40
While _MouseInput
If _MouseWheel = -1 Then Cls: size = size + 1
If _MouseWheel = 1 Then Cls: size = size - 1
Wend
If size < 1 Then size = 70
If size > 70 Then size = 1
Text1 ((800 - ls * _FontWidth) / 2) - (size * 20), ((600 - _FontHeight) / 2) - (size * 8), size * _FontHeight, &HFFFF0000, s$
Locate 1, 1: Print "Move mouse wheel to zoom"
Locate 20, 1: Print "Press Esc to quit"
Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText12
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #4
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32956#pid32956
' From: Steffan-68, Member
' Date: 3/25/2025 01:51 PM
' Or do you mean something like that?
' I just found it in the collection , It's from B+
Sub BigRotatingText4
_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
Const xmax = 1200
Const ymax = 700
Const x0 = 600
Const y0 = 350
Const radius = 240
Const r2 = 20
'' Global vars
'ReDim Shared fv72& ' testing verdanab.ttf
Screen _NewImage(xmax, ymax, 32)
_Delay .25
'_ScreenMove _Middle
_ScreenMove 0, 0
''test font load
'_FONT fv72&
'S$ = "helloworld pdq"
'PRINT S$, _PRINTWIDTH(S$), _FONTHEIGHT(fv72&)
'LINE (0, 0)-STEP(_PRINTWIDTH(S$), _FONTHEIGHT(fv72&)), , B
'END
fv72& = _LoadFont("verdanab.ttf", 72)
a = 1: dir = 1: dir2 = 1: runner = 0
ca = _Pi(2 / 20)
t$ = "Scale and rotate text strings"
Randomize Timer
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
_AutoDisplay
Screen 0
End Sub ' BigRotatingText4
' /////////////////////////////////////////////////////////////////////////////
' 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 ' drwString
' /////////////////////////////////////////////////////////////////////////////
' USED BY: drwString
' This sub gives really nice control over displaying an Image.
' by BPlus
'
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
'
' Purpose:
' Locate and display image, scaling and/or rotating the displayed image around
' its central point.
'
' Passed parameters:
' centerX, centerY sends the center point of where the image is to be displayed
' Image sends the source image handle
' xScale and yScale send width and height stretching parameters 1=original size
' Rotation sends rotation of image in degrees 0=east, 270=north
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 i&
_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 ' RotoZoom2
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #8
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32962#pid32962
' From: Petr, Mini-Mod
' Date: 3/25/2025, 04:59 PM
' 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.
Sub BigText8
font = _LoadFont("arial.ttf", 40, "monospace")
text$ = "this is a test" + Chr$(13) + Chr$(13) + "IS IT WORKING?" + Chr$(13) + Chr$(13) + "??????????"
virtual = _NewImage(_FontWidth(font) * Len(text), _FontHeight(font), 32)
_Font font, virtual
_PrintString (0, 0), text$, virtual
Screen _NewImage(1024, 768, 32)
Do Until I$ = Chr$(27)
I$ = InKey$
Do While _MouseInput
zoom = zoom + _MouseWheel / 10
Loop
Cls
Locate 1, 1: Print "Move mouse wheel"
Locate 20, 1: Print "Press Esc to quit"
DoZoom virtual, _MouseX, _MouseY, zoom
_Display
_Limit 20
Loop
_AutoDisplay
Screen 0
If virtual < -1 Or virtual > 0 Then _FreeImage virtual
End Sub ' BigText8
' /////////////////////////////////////////////////////////////////////////////
Sub DoZoom (image, x, y, zoom)
w = _Width(image)
h = _Height(image)
_PutImage (x, y)-(x + w * zoom, y + w * zoom), image, 0
End Sub ' DoZoom
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #10
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32964#pid32964
' From: SMcNeill, Super Moderator
' Date: 06:47 PM (This post was last modified: Yesterday, 06:51 PM by SMcNeill.)
'
' For this type of quick thing, I have two simple routines to use: TextToImage
' and ScaleImage
'
' 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.
Sub ScrollBigText10
Dim bFinished%: bFinished% = _FALSE
$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
Locate 2, 1: Print "Press Esc to exit.";
'_PutImage (x, 0), tempImage, Display
_PutImage (x, 100), tempImage, Display
_Display
_Limit 120
If InKey$ = Chr$(27) Then bFinished% = _TRUE: Exit For
Next x
_FreeImage tempImage
i = i * 2 'double print size every pass
Loop Until i >= 16 Or bFinished% = _TRUE
_AutoDisplay
Screen 0
If Display < -1 Or Display > 0 Then _FreeImage Display
End Sub ' ScrollBigText10
' /////////////////////////////////////////////////////////////////////////////
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&
'DON'T TRY TO FREE THE IMAGE HERE!
'If NewImage& < -1 Or NewImage& > 0 Then _FreeImage NewImage&
End Function ' ScaleImage&
' /////////////////////////////////////////////////////////////////////////////
' 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).
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
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
'DON'T TRY TO FREE THE IMAGE HERE!
'If TextToImage_temp& < -1 Or TextToImage_temp& > 0 Then _FreeImage TextToImage_temp&
End Function ' TextToImage&
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #11
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32965#pid32965
' From: bplus, Mini-Mod
' Date: 3/25/2025 07:17 PM (This post was last modified: Yesterday, 07:22 PM by bplus.)
'
' Hello in red on white at 12X's height in the middle of the screen:
Sub BigText11
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
_ScreenMove 0, 0
s$ = " Hello "
ls = Len(s$)
mult = 12
Text11 (800 - ls * _FontWidth * mult) / 2, (600 - _FontHeight * mult) / 2, mult * _FontHeight, &HFFFF0000, &HFFFFFFFF, s$
Locate 30, 1: Print "Press Esc to continue."
Do: Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText11
' /////////////////////////////////////////////////////////////////////////////
Sub Text11 (x, y, textHeight, fore As _Unsigned Long, back 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 fore, back: _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&
End Sub ' Text11
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #14
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32974#pid32974
' From: SierraKen, Mini-Mod
' Date: 3/25/2025 09:01 PM (This post was last modified: Yesterday, 09:03 PM by SierraKen.)
'
' Thanks B+. After I made that, I realized you were replying to someone,
' I guess my head was in the clouds...
'
' So I decided to make the text side-scroller news that he wanted,
' with a little story I made up. Smile
' This is using the resized text that Bplus posted.
' Side News Scroller by SierraKen
' Resized text code by Bplus.
Sub ScrollBigText14
Dim s$(19)
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
ls = Len(s$)
size = 2
t = 1
Read s$(t)
xx = -400
Do
_Limit 40
xx = xx + 4
If xx > 550 Then
t = t + 1
xx = -400
If t = 18 Then Restore story: t = 1
Read s$(t)
End If
'Text1 ((800 - ls * _FontWidth) / 2) - (2 * xx), ((600 - _FontHeight) / 2) - (size * 16), size * _FontHeight, &HFFFF0000, s$(t)
Text1 ((600 - ls * _FontWidth) / 2) - (2 * xx), ((200 - _FontHeight) / 2) - (size * 16), size * _FontHeight, &HFFFF0000, s$(t)
_Delay .05
_Display
Cls
Locate 1, 1: Print "Wait for it...";
Locate 20, 1: Print "Press Esc to exit.";
Loop Until InKey$ = Chr$(27)
_AutoDisplay
Screen 0
story:
Data "Hello...","My name is Computer 5000...","Today's weather is Sunny with a breeze of 5 mph from the West..."
Data "Today's news is that everything is a-okay...","Breaking News..."
Data "Martians have landed!...","This may be my last newscast...","Over to you on the field Ralph..."
Data "Yeah it looks bad, Martians have destroyed everything...","Oh wait! Here comes the helicopters!..."
Data "*CRASH BOOM SMACK.... BZZZZZZZZZZZZ*...","Come in Ralph, you there? We seem to have lost the transmission..."
Data "Now over to Henry...","It looks like everything is under control...","The Martians are leaving now..."
Data "I guess they didn't want anything here on Earth...","They said all of our stuff is outdated, so they are leaving the planet..."
End Sub ' ScrollBigText14
Posts: 586
Threads: 103
Joined: Apr 2022
Reputation:
47
03-26-2025, 10:17 PM
(This post was last modified: 03-26-2025, 10:19 PM by SierraKen.)
Awesome Madscijr! Thanks for adding mine. One thing you forgot though, your menu goes to 10, not 9, so where it says "Your choice" just change 9 to 10.
Ah yeah, it locks up after it goes to the menu again. I don't know if it's because I used a different app during the menu or not though.
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
Good catch. It should work, if it doesn't let me know.
Thanks for your contribution!
Posts: 935
Threads: 126
Joined: Apr 2022
Reputation:
22
Got it rotating and scrolling and scaling in multi-colors... - At menu select choice 1
- Then type Y to scroll (no zoom) or N to zoom (no scroll)
- Scrolling logic is a little wonky - I'm terrible at geometry/trig type math so I just fudged it by adding spaces to the start/end of the text - but it works.
Thanks for all your guys' help!
Code: (Select All) ' Global vars
ReDim Shared fv72& ' used by subs BigRotatingText4, drwString (for testing verdanab.ttf)
Dim in$
Do
_Title "Big scrolling text demos"
Screen 0: _ScreenMove 0, 0
Cls
Color cLtGrayT&
Print
Print "Scaled, rotated, scrolling, colored text demos"
Print
Color cCyanT&
Print " 1. BigRotatingText18 by madscijr/Steffan-68/bplus";
Color cYellowT&
Print " <- THE NEW ONE"
Color cLtGrayT&
Print " 2. BigTextScroll17 by madscijr"
Print " 3. ScrollingLED by bplus"
Print " 4. BigText3 by bplus"
Print " 5. BigRotatingText4 by Steffan-68"
Print " 6. BigText8 by Petr"
Print " 7. BigText0 by madscijr"
Print " 8. BigText11 by bplus"
Print " 9. BigText12 by SierraKen"
Print "10. ScrollBigText10 by SMcNeill"
Print "11. ScrollBigText14 by SierraKen"
Print
Print "NOTE: if you use _Display remember to do _AutoDisplay at the end! :-)"
Print
Input "Your choice (1-11 or Q to quit) "; in$
in$ = _Trim$(UCase$(in$))
Select Case in$
Case "1": BigRotatingText18
Case "2": BigTextScroll17
Case "3": ScrollingLED
Case "4": BigText3
Case "5": BigRotatingText4
Case "6": BigText8
Case "7": BigText0
Case "8": BigText11
Case "9": BigText12
Case "10": ScrollBigText10
Case "11": ScrollBigText14
Case "Q": Exit Do
Case Else:
End Select
_KeyClear ' CLEAR KEYBOARD BUFFER
Loop
Print "End of demo."
End
' /////////////////////////////////////////////////////////////////////////////
' BASED ON Steffan-68's code at:
' print + scroll text big to an image (is there a better way?), reply #4
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32956#pid32956
Sub BigRotatingText18
' The following CONSTants or TYPES are for the demo and NOT needed for the 2 main subs
Const xMax = 800
Const yMax = 600
Const cMinScale = 0
Const cMaxScale = 5
Dim sngRotation As Single
Dim sngRotSpeed As Single
Dim zDirection As Single
Dim rDirection As Integer
Dim dir1 As Integer
Dim dir2 As Integer
Dim midX, midY, xScale, yScale As Single
Dim iWord As Integer
Dim in$
Dim message$, m2$
Dim iMidScale As Integer
Dim iScroll, iScrollWidth1, iScrollWidth2, iScrollDir, iScrollLen As Integer
ReDim arrColor(-1) As _Unsigned Long
ReDim arrText(0) As String
_Title "Scroll + scale + rotate font text string of different colors"
' GET PREFERENCES
Cls
Do
Input "TO SCROLL OR NOT TO SCROLL (Y or N)"; in$
in$ = Left$(_Trim$(UCase$(in$)), 1)
If in$ = "Y" Or in$ = "N" Then Exit Do
Loop
' INIT SCREEN
Screen _NewImage(xMax, yMax, 32): _Delay .25: _ScreenMove 0, 0
' INITIALIZE TEXT
message$ = Chr$(34) + "Oh freddled gruntbuggly, Thy micturitions are to me, As plurdled gabbleblotchits, On a lurgid bee." + Chr$(34) + " - Prostetnic Vogon Jeltz" + " ."
' Add delimiters so we have extra array elements at beginning and end for extra spacing
message$ = " _ " + message$ + " "
' break text up into an array of words where delimeter = tab
split message$, " ", arrText()
' add spaces back in after each word
For iWord = LBound(arrText) + 1 To UBound(arrText) - 1
arrText(iWord) = arrText(iWord) + " "
Next iWord
' IF SCROLLING, FIGURE OUT EXTRA SPACING
If in$ = "Y" Then
iMidScale = (cMaxScale - cMinScale) / 2
iScrollWidth1 = (_Width / _FontWidth) * iMidScale ' start with adding enough spaces at end arrText(ubound(arrText)) to push message off screen
iScrollWidth2 = iScrollWidth1 * 2
arrText(UBound(arrText)) = String$(iScrollWidth2, " ")
m2$ = message$ + arrText(UBound(arrText)) ' add extra space at end
iScrollDir = -1 ' -1=remove spaces from end, 1=add spaces to beginning
Else
m2$ = message$
iScrollDir = 0
End If
' INITIALIZE
GetColorArray arrColor()
sngRotation = 1
If iScrollDir = 0 Then
xScale = cMinScale
yScale = xScale
zDirection = .05
sngRotSpeed = _Pi(1 / 180)
Else
xScale = iMidScale
yScale = xScale
zDirection = 0
sngRotSpeed = _Pi(1 / 360)
End If
rDirection = 1
rot = 0
midX = xMax / 2
midY = yMax / 2
' LOOP UNTIL USER PRESSES ESC
While _KeyDown(27) = 0
_Dest 0: Cls , _RGB32(0, 0, 0)
' DRAW ROTATED/SCALED/SCROLLED COLORED TEXT
drwColorString m2$, arrText(), arrColor(), midX, midY, xScale, yScale, sngRotation, iScroll
Color _RGB32(255, 0, 0), _RGBA32(0, 0, 0, 0)
Locate 1, 1: Print "Scroll + scale + rotate + scroll multicolor text string"
' Rotate in the current rotation direction
'sngRotation = sngRotation + _Pi(1 / 45) * rDirection
sngRotation = sngRotation + sngRotSpeed * rDirection
' If we have rotated 360 degrees, reverse rotation direction
' where 360 degrees = 6.28319 radians = _Pi(2)
If sngRotation > _Pi(2) Then
rDirection = -rDirection
ElseIf sngRotation < _Pi(-2) Then
rDirection = -rDirection
End If
' Zoom in or out
' if zoomed < 0x or > 5x then reverse zDirection
If zDirection > 0 Then
xScale = xScale + zDirection: yScale = xScale
If xScale > cMaxScale Then zDirection = -zDirection
ElseIf zDirection < 0 Then
xScale = xScale + zDirection: yScale = xScale
If xScale <= 0 Then zDirection = -zDirection
End If
' Scroll text?
If iScrollDir = -1 Then
' -1 = remove spaces from end
iScrollLen = Len(arrText(UBound(arrText)))
If iScrollLen > 0 Then
arrText(UBound(arrText)) = String$(iScroll, " ")
m2$ = message$ + arrText(UBound(arrText))
iScroll = iScroll - 1
Else
arrText(UBound(arrText)) = ""
m2$ = message$
iScrollDir = 1
End If
Locate 4, 1: Print "iScrollDir = " + _Trim$(Str$(iScrollDir))
Locate 3, 1: Print "iScroll = " + _Trim$(Str$(iScroll))
Locate 5, 1: Print "iScrollLen = " + _Trim$(Str$(iScrollLen))
Locate 6, 1: Print " 0" + " -> " + Right$(" " + _Trim$(Str$(iScrollLen)), 4)
ElseIf iScrollDir = 1 Then
' 1 = add spaces to beginning
iScrollLen = Len(arrText(LBound(arrText)))
If iScrollLen < iScrollWidth1 Then
arrText(LBound(arrText)) = String$(iScroll, " ")
m2$ = arrText(LBound(arrText)) + message$
iScroll = iScroll + 1
Else
arrText(LBound(arrText)) = ""
arrText(UBound(arrText)) = String$(iScrollWidth2, " ")
m2$ = message$ + arrText(UBound(arrText))
iScrollDir = -1
End If
Locate 4, 1: Print "iScrollDir = " + _Trim$(Str$(iScrollDir))
Locate 3, 1: Print "iScroll = " + _Trim$(Str$(iScroll))
Locate 5, 1: Print "iScrollLen = " + _Trim$(Str$(iScrollLen))
Locate 6, 1: Print Right$(" " + _Trim$(Str$(iScrollLen)), 4) + " <- " + " 0"
End If
' Refresh display every FPS
_Display
_Limit 60
Wend
_AutoDisplay
Screen 0
End Sub ' BigRotatingText18
' /////////////////////////////////////////////////////////////////////////////
' drwColorString 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 drwColorString (S$, c As _Unsigned Long, midX, midY, xScale, yScale, Rotation)
Sub drwColorString (message$, arrText() As String, arrColor() As _Unsigned Long, _
midX as single, midY as single, xScale as single, yScale as single, _
Rotation as single, iScroll as integer)
Dim storeDest&
Dim I&
Dim iWord As Integer
Dim iColor As Integer
Dim iExtraSpace As Integer
' INITIALIZE
storeDest& = _Dest
I& = _NewImage(_PrintWidth(message$), _FontHeight, 32)
_Dest I&: Cls , _RGBA32(0, 0, 0, 0)
iExtraSpace = 0
' COLOR NEXT WORD
iColor = LBound(arrColor)
For iWord = LBound(arrText) To UBound(arrText)
Color arrColor(iColor), _RGBA32(0, 0, 0, 0) ' new color for each word
' using blank space to position next word
_PrintString (0, 0), String$(iExtraSpace%, " ") + arrText(iWord)
iExtraSpace = iExtraSpace + Len(arrText(iWord))
iColor = iColor + 1: If iColor > UBound(arrColor) Then iColor = LBound(arrColor)
Next iWord
' DRAW IT
_Dest storeDest&
RotoZoom2 midX, midY, I&, xScale, yScale, Rotation
' CLEANUP
_FreeImage I&
End Sub ' drwColorString
' /////////////////////////////////////////////////////////////////////////////
' scroll big text v0.17 by madscijr
' TODO: make more efficient + simpler
Sub BigTextScroll17
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 Esc to exit."
Do: Loop Until InKey$ = Chr$(27)
'Screen 0: Cls: Print "Finished"
Screen 0
If imgScreen& < -1 Or imgScreen& > 0 Then _FreeImage imgScreen&
End Sub ' BigTextScroll17
' /////////////////////////////////////////////////////////////////////////////
' Prints string in$
' on image imgDest&
' at location (x%, y%)
' in color fgColor~&, bgColor~&
' blown up scale% times
' requires array arrAlpha derived from sub GetBigFont
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
' /////////////////////////////////////////////////////////////////////////////
' Prints a single character sChar$
' on image imgDest&
' at location (x%, y%)
' in color fgColor~&, bgColor~&
' blown up scale% times
' requires array arrAlpha derived from sub GetBigFont
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns an array containing the pixel information for the current font,
' in the form:
' arrAlpha( {character code}, {x pixel}, {y pixel})
' 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
' /////////////////////////////////////////////////////////////////////////////
' display "hello" 2x bigger on screen
' without needing an array
' finally works, yay!
' _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
Sub BigText0
Dim sourceHandle&
Dim destHandle&
Dim in$
Dim dx1 As Integer, dy1 As Integer, dx2 As Integer, dy2 As Integer
Dim iWidth&, iHeight&
Cls: Print "please wait"
'_Display
in$ = "hello"
iWidth& = _FontWidth * Len(in$)
iHeight& = _FontHeight
InitImage sourceHandle&, iWidth&, iHeight&, _RGB32(0, 0, 0)
'InitImage sourceHandle&, 40, 16, _RGB32(0, 0, 0)
'_Dest sourceHandle&
Screen sourceHandle&: _ScreenMove 0, 0
Locate 1, 1
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
Print in$;
'_Dest 0
'Print "iWidth&=" + _Trim$(Str$(iWidth&))
'Print "iHeight&=" + _Trim$(Str$(iHeight&))
'Sleep
InitImage destHandle&, 1024, 768, _RGB32(0, 0, 0)
Screen destHandle&: _ScreenMove 0, 0
_Dest destHandle&
dx1 = 50
dy1 = 90
dx2 = dx1 + ((iWidth& * 2) - 1)
dy2 = dy1 + ((iHeight& * 2) - 1)
' size full source to destination coordinate area
_PutImage (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&
Locate 20, 1: Print "Press Esc to continue"
Do: Loop Until InKey$ = Chr$(27)
Screen 0
FreeImage sourceHandle&
FreeImage destHandle&
End Sub ' BigText0
' /////////////////////////////////////////////////////////////////////////////
' Initializes an image
' (if it already exists, frees it up and re-instantiates)
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
' Frees image if it exists
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' Returns 100% transparent RGB color
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' /////////////////////////////////////////////////////////////////////////////
' Used by sub GetColorArray
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
' /////////////////////////////////////////////////////////////////////////////
' arrColor Should be redimmed and not dimmed before calling, e.g.,
' Redim arrColor(-1) : GetColorArray arrColor()
Sub GetColorArray (arrColor() As _Unsigned Long)
ReDim arrColor(-1) As _Unsigned Long
AddColor _RGB32(255, 0, 0), arrColor()
AddColor _RGB32(255, 69, 0), arrColor()
AddColor _RGB32(255, 255, 0), arrColor()
AddColor _RGB32(0, 255, 0), arrColor()
AddColor _RGB32(0, 255, 255), arrColor()
AddColor _RGB32(0, 0, 255), arrColor()
AddColor _RGB32(128, 0, 255), arrColor()
End Sub ' GetColorArray
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEXT MODE COLOR CODE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cBlackT&
cBlackT& = 0
End Function
Function cBlueT&
cBlueT& = 1
End Function
Function cGreenT&
cGreenT& = 2
End Function
Function cLtBlueT&
cLtBlueT& = 3
End Function
Function cRedT&
cRedT& = 4
End Function
Function cPurpleT&
cPurpleT& = 5
End Function
Function cOrangeT&
cOrangeT& = 6
End Function
Function cWhiteT&
cWhiteT& = 7
End Function
Function cGrayT&
cGrayT& = 8
End Function
Function cPeriwinkleT&
cPeriwinkleT& = 9
End Function
Function cLtGreenT&
cLtGreenT& = 10
End Function
Function cCyanT&
cCyanT& = 11
End Function
Function cLtRedT&
cLtRedT& = 12
End Function
Function cPinkT&
cPinkT& = 13
End Function
Function cYellowT&
cYellowT& = 14
End Function
Function cLtGrayT&
cLtGrayT& = 15
End Function
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEXT MODE COLOR CODE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #2
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32954#pid32954
' From: bplus, Mini-Mod
' Date: 3/25/2025 03:59 PM
'
' Nice!
'
' Here is my lecture on that subject:
' Building a Scrolling LED Screen by b+ 2021-05-08
' https://staging.qb64phoenix.com/showthread.php?tid=1693&pid=16764#pid16764
Sub ScrollingLED
_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
_ScreenMove 0, 0
' 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$)
_AutoDisplay
Screen 0
If sign < -1 Or sign > 0 Then _FreeImage sign
End Sub ' ScrollingLED
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #3
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32955#pid32955
' From: bplus, Mini-Mod
' Date: 3/25/2025 01:51 PM
' @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:
Sub BigText3
_Title "Text1 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 i
row = _Height - 64 - 8
size = 64
For i = 20 To 1 Step -1
t$ = "This is line" + Str$(i)
Text0 _Width - Len(t$) * size / 2 - 20, row, size, &HFFFF8800, "This is line" + Str$(i)
size = 64 * .9 ^ (21 - i)
row = row - size - 1
Next i
_PrintString (350, _Height - 20), "OK tests done. Press Esc to exit."
Do: Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText3
' /////////////////////////////////////////////////////////////////////////////
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 ' Text8
' /////////////////////////////////////////////////////////////////////////////
Sub Text0 (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 ' Text0
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #12
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32969#pid32969
' From: SierraKen, Mini-Mod
' Date: 3/25/2025 07:50 PM (This post was last modified: Yesterday, 07:52 PM by SierraKen.)
' That's a great way Bplus! Here is a little scrolling mod I just made using the
' Mouse Wheel, although I think you have done this before. This also centers the
' Hello on the screen pretty good.
' Bplus Font Resize - Scrolling Mod by SierraKen
Sub BigText12
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
_ScreenMove 0, 0
s$ = "Hello"
ls = Len(s$)
size = 1
Do
_Limit 40
While _MouseInput
If _MouseWheel = -1 Then Cls: size = size + 1
If _MouseWheel = 1 Then Cls: size = size - 1
Wend
If size < 1 Then size = 70
If size > 70 Then size = 1
Text0 ((800 - ls * _FontWidth) / 2) - (size * 20), ((600 - _FontHeight) / 2) - (size * 8), size * _FontHeight, &HFFFF0000, s$
Locate 1, 1: Print "Move mouse wheel to zoom"
Locate 20, 1: Print "Press Esc to quit"
Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText12
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #4
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32956#pid32956
' From: Steffan-68, Member
' Date: 3/25/2025 01:51 PM
' Or do you mean something like that?
' I just found it in the collection , It's from B+
Sub BigRotatingText4
_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
Const xmax = 1200
Const ymax = 700
Const x0 = 600
Const y0 = 350
Const radius = 240
Const r2 = 20
'' Global vars
'ReDim Shared fv72& ' testing verdanab.ttf
Screen _NewImage(xmax, ymax, 32)
_Delay .25
'_ScreenMove _Middle
_ScreenMove 0, 0
''test font load
'_FONT fv72&
'S$ = "helloworld pdq"
'PRINT S$, _PRINTWIDTH(S$), _FONTHEIGHT(fv72&)
'LINE (0, 0)-STEP(_PRINTWIDTH(S$), _FONTHEIGHT(fv72&)), , B
'END
fv72& = _LoadFont("verdanab.ttf", 72)
a = 1: dir = 1: dir2 = 1: runner = 0
ca = _Pi(2 / 20)
t$ = "Scale and rotate text strings"
Randomize Timer
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
_AutoDisplay
Screen 0
End Sub ' BigRotatingText4
' /////////////////////////////////////////////////////////////////////////////
' 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 ' drwString
' /////////////////////////////////////////////////////////////////////////////
' USED BY: drwString
' This sub gives really nice control over displaying an Image.
' by BPlus
'
' Scale rotate font text strings by B+
' https://qb64phoenix.com/forum/showthread.php?tid=414&highlight=rotate+text
'
' Purpose:
' Locate and display image, scaling and/or rotating the displayed image around
' its central point.
'
' Passed parameters:
' centerX, centerY sends the center point of where the image is to be displayed
' Image sends the source image handle
' xScale and yScale send width and height stretching parameters 1=original size
' Rotation sends rotation of image in degrees 0=east, 270=north
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 i&
_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 ' RotoZoom2
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #8
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32962#pid32962
' From: Petr, Mini-Mod
' Date: 3/25/2025, 04:59 PM
' 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.
Sub BigText8
font = _LoadFont("arial.ttf", 40, "monospace")
text$ = "this is a test" + Chr$(13) + Chr$(13) + "IS IT WORKING?" + Chr$(13) + Chr$(13) + "??????????"
virtual = _NewImage(_FontWidth(font) * Len(text), _FontHeight(font), 32)
_Font font, virtual
_PrintString (0, 0), text$, virtual
Screen _NewImage(1024, 768, 32)
Do Until I$ = Chr$(27)
I$ = InKey$
Do While _MouseInput
zoom = zoom + _MouseWheel / 10
Loop
Cls
Locate 1, 1: Print "Move mouse wheel"
Locate 20, 1: Print "Press Esc to quit"
DoZoom virtual, _MouseX, _MouseY, zoom
_Display
_Limit 20
Loop
_AutoDisplay
Screen 0
If virtual < -1 Or virtual > 0 Then _FreeImage virtual
End Sub ' BigText8
' /////////////////////////////////////////////////////////////////////////////
Sub DoZoom (image, x, y, zoom)
w = _Width(image)
h = _Height(image)
_PutImage (x, y)-(x + w * zoom, y + w * zoom), image, 0
End Sub ' DoZoom
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #10
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32964#pid32964
' From: SMcNeill, Super Moderator
' Date: 06:47 PM (This post was last modified: Yesterday, 06:51 PM by SMcNeill.)
'
' For this type of quick thing, I have two simple routines to use: TextToImage
' and ScaleImage
'
' 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.
Sub ScrollBigText10
Dim bFinished%: bFinished% = _FALSE
$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
Locate 2, 1: Print "Press Esc to exit.";
'_PutImage (x, 0), tempImage, Display
_PutImage (x, 100), tempImage, Display
_Display
_Limit 120
If InKey$ = Chr$(27) Then bFinished% = _TRUE: Exit For
Next x
_FreeImage tempImage
i = i * 2 'double print size every pass
Loop Until i >= 16 Or bFinished% = _TRUE
_AutoDisplay
Screen 0
If Display < -1 Or Display > 0 Then _FreeImage Display
End Sub ' ScrollBigText10
' /////////////////////////////////////////////////////////////////////////////
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&
'DON'T TRY TO FREE THE IMAGE HERE!
'If NewImage& < -1 Or NewImage& > 0 Then _FreeImage NewImage&
End Function ' ScaleImage&
' /////////////////////////////////////////////////////////////////////////////
' 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).
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
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
'DON'T TRY TO FREE THE IMAGE HERE!
'If TextToImage_temp& < -1 Or TextToImage_temp& > 0 Then _FreeImage TextToImage_temp&
End Function ' TextToImage&
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #11
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32965#pid32965
' From: bplus, Mini-Mod
' Date: 3/25/2025 07:17 PM (This post was last modified: Yesterday, 07:22 PM by bplus.)
'
' Hello in red on white at 12X's height in the middle of the screen:
Sub BigText11
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
_ScreenMove 0, 0
s$ = " Hello "
ls = Len(s$)
mult = 12
Text11 (800 - ls * _FontWidth * mult) / 2, (600 - _FontHeight * mult) / 2, mult * _FontHeight, &HFFFF0000, &HFFFFFFFF, s$
Locate 30, 1: Print "Press Esc to continue."
Do: Loop Until InKey$ = Chr$(27)
Screen 0
End Sub ' BigText11
' /////////////////////////////////////////////////////////////////////////////
Sub Text11 (x, y, textHeight, fore As _Unsigned Long, back 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 fore, back: _PrintString (0, 0), txt$
_PutImage (x, y)-Step(Len(txt$) * textHeight / 2, textHeight), i&, cur&
Color fg, bg: _FreeImage i&: _Dest cur&
End Sub ' Text11
' /////////////////////////////////////////////////////////////////////////////
' print + scroll text big to an image (is there a better way?), reply #14
' https://qb64phoenix.com/forum/showthread.php?tid=3558&pid=32974#pid32974
' From: SierraKen, Mini-Mod
' Date: 3/25/2025 09:01 PM (This post was last modified: Yesterday, 09:03 PM by SierraKen.)
'
' Thanks B+. After I made that, I realized you were replying to someone,
' I guess my head was in the clouds...
'
' So I decided to make the text side-scroller news that he wanted,
' with a little story I made up. Smile
' This is using the resized text that Bplus posted.
' Side News Scroller by SierraKen
' Resized text code by Bplus.
Sub ScrollBigText14
Dim s$(19)
Screen _NewImage(800, 600, 32)
'_ScreenMove 250, 60
ls = Len(s$)
size = 2
t = 1
Read s$(t)
xx = -400
Do
_Limit 40
xx = xx + 4
If xx > 550 Then
t = t + 1
xx = -400
If t = 18 Then Restore story: t = 1
Read s$(t)
End If
'Text0 ((800 - ls * _FontWidth) / 2) - (2 * xx), ((600 - _FontHeight) / 2) - (size * 16), size * _FontHeight, &HFFFF0000, s$(t)
Text0 ((600 - ls * _FontWidth) / 2) - (2 * xx), ((200 - _FontHeight) / 2) - (size * 16), size * _FontHeight, &HFFFF0000, s$(t)
_Delay .05
_Display
Cls
Locate 1, 1: Print "Wait for it...";
Locate 20, 1: Print "Press Esc to exit.";
Loop Until InKey$ = Chr$(27)
_AutoDisplay
Screen 0
story:
Data "Hello...","My name is Computer 5000...","Today's weather is Sunny with a breeze of 5 mph from the West..."
Data "Today's news is that everything is a-okay...","Breaking News..."
Data "Martians have landed!...","This may be my last newscast...","Over to you on the field Ralph..."
Data "Yeah it looks bad, Martians have destroyed everything...","Oh wait! Here comes the helicopters!..."
Data "*CRASH BOOM SMACK.... BZZZZZZZZZZZZ*...","Come in Ralph, you there? We seem to have lost the transmission..."
Data "Now over to Henry...","It looks like everything is under control...","The Martians are leaving now..."
Data "I guess they didn't want anything here on Earth...","They said all of our stuff is outdated, so they are leaving the planet..."
End Sub ' ScrollBigText14
|
