Almost all of this code comes from my Earth and Moon orbiting app I made a couple weeks ago. I decided to make it so you can add text that orbits the Sun instead of Earth. It uses the Comic Sans font. Thanks to Steve for the array idea for the font sizes! Tell me what you think. The text itself doesn't bend or turn, but it does change sizes as it goes away and comes back. You can choose anything up to 5 letters, numbers, or characters in the beginning. To restart and use different text, press the Space Bar.
Code: (Select All)
'3D Orbiting Text by SierraKen
'Made on August 2, 2022.
'Thanks to Steve for the font array idea!
Dim starx(1000), stary(1000)
Dim dx(1000), dy(1000)
Dim sz(1000)
Dim speed(1000)
Dim cx As Integer, cy As Integer, ra As Integer, cl As _Unsigned Long
Dim Font(8) As Long
_Title "3D Orbiting Text by SierraKen - Press Space Bar to restart"
Screen _NewImage(800, 600, 32)
Font(0) = _LoadFont("Comic.ttf", 10)
Font(1) = _LoadFont("Comic.ttf", 12)
Font(2) = _LoadFont("Comic.ttf", 14)
Font(3) = _LoadFont("Comic.ttf", 16)
Font(4) = _LoadFont("Comic.ttf", 18)
Font(5) = _LoadFont("Comic.ttf", 22)
Font(6) = _LoadFont("Comic.ttf", 24)
Font(7) = _LoadFont("Comic.ttf", 26)
start:
f = 5
_Font Font(f)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Cls
start2:
Color _RGB32(255, 255, 255)
Print: Print
Print "Type any 5 letter or less word, number, or characters: "
Input text$
Print: Print
If Len(text$) > 5 Then Print "Too long, try again.": GoTo start2:
If Len(text$) < 1 Then Print "You didn't type anything, try again.": GoTo start2:
Cls
Do
_Limit 20
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoTo start:
'Starfield
fillCircle cx, cy, 5, cl
If sp < .0005 Then sp = .0005
If sp > .1 Then sp = .1
warp = (sp * 100) + 1
If warp > 10 Then warp = 10
warp = Int(warp)
stars = Int(Rnd * 100) + 1
If stars > 25 Then
ss = ss + 1
If ss > 950 Then ss = 1
'Set starting position.
startx = Rnd * 490
starty = Rnd * 390
st = Int(Rnd * 360)
xx = (Sin(st) * startx) + 400
yy = (Cos(st) * starty) + 300
starx(s) = xx
stary(s) = yy
'Set direction to move.
dx(s) = ((xx - 400) / 30)
dy(s) = ((yy - 300) / 30)
'Set size.
sz(s) = Rnd
'Set speed
speed(s) = .1
End If
If yy > 640 Then yy = 0
For tt = 1 To 950
speed(tt) = speed(tt) * (1.05 + sp)
stary(tt) = stary(tt) + dy(tt) * speed(tt)
starx(tt) = starx(tt) + dx(tt) * speed(tt)
cx = starx(tt): cy = stary(tt)
ra = sz(tt) + .5
cl = _RGB32(255, 255, 255)
fillCircle cx, cy, ra, cl
'skip:
Next tt
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
oldx3 = x3
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.55 + 300
r2 = (Cos(t) * 180) / _Pi / 1.55 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 80) / _Pi / 2 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If r2 < 20 Then f = 0
If r2 < 30 And r2 >= 20 Then f = 1
If r2 < 40 And r2 >= 30 Then f = 2
If r2 < 50 And r2 >= 40 Then f = 3
If r2 < 60 And r2 >= 50 Then f = 4
If r2 < 70 And r2 >= 60 Then f = 5
If r2 < 80 And r2 >= 70 Then f = 6
If r2 >= 80 Then f& = 7
_Font Font(f)
If y2 < 290 Then
'Text
_PrintString (x2 - 30, y2), text$
'Moon
cc4 = 200
For s = .25 To r3 Step .25
cc4 = cc4 - 2
Circle (x3, y3), s, _RGB32(cc4, cc4, cc4)
Next s
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
If y2 >= 290 Then
'Text
_PrintString (x2 - 30, y2), text$
'Moon
cc5 = 200
For s = .25 To r3 Step .25
cc5 = cc5 - 2
Circle (x3, y3), s, _RGB32(cc5, cc5, cc5)
Next s
cc5 = 0
If y3 < y2 Then
'Text
_PrintString (x2 - 30, y2), text$
End If
End If
If x3 > oldx3 And y2 < 290 And (Point(x3 + r3 + 1, y3) <> _RGB32(0, 0, 0) Or Point(x3 + r3 + 1, y3)) <> _RGB32(255, 255, 255) Then
'Text
_PrintString (x2 - 30, y2), text$
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
End If
_Delay .05
_Display
Cls
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
