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
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