Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: Petr on February 27, 2021, 02:24:23 pm

Title: Bounded font
Post by: Petr on February 27, 2021, 02:24:23 pm
Hi. Maybe it could be useful for someone.

Code: QB64: [Select]
  1.  
  2.  
  3. 'usage: NewImage& = OKRAJ&(the color of the point around which to draw the border, border color, border size, source image handle)
  4. SCREEN _NEWIMAGE(1024, 768, 32)
  5. COLOR &HFFFF0000
  6. F = _LOADFONT("arial.ttf", 100, "bold")
  7. _FONT F, 0
  8.  
  9. LOCATE 3, 30
  10. PRINT "Hi, QB64 Gang!"
  11.  
  12. _PUTIMAGE , OKRAJ(&HFFFF0000, &HFFFFFFFF, 3, 0)
  13.  
  14.  
  15. FUNCTION OKRAJ& (K~&, K2~&, SIZE&, D&)
  16.     OKRAJ& = _NEWIMAGE(_WIDTH(D&), _HEIGHT(D&), 32)
  17.     DIM m AS _MEM, s AS _MEM, T AS LONG, KLR AS _UNSIGNED LONG, W AS LONG
  18.     m = _MEMIMAGE(OKRAJ&)
  19.     s = _MEMIMAGE(D&)
  20.     DO UNTIL T& = s.SIZE
  21.  
  22.         IF _MEMGET(s, s.OFFSET + T&, _UNSIGNED LONG) = K~& THEN 'Find point with K~& color
  23.  
  24.             'hledam od bodu doprava:       Search to right from point K~&
  25.             left& = T&
  26.             cil& = SIZE& * 4 + T&
  27.             IF cil& < s.SIZE THEN
  28.                 DO UNTIL left& = cil&
  29.                     KLR = _MEMGET(s, s.OFFSET + left&, _UNSIGNED LONG)
  30.                     IF KLR <> K2~& AND KLR <> K~& THEN _MEMPUT m, m.OFFSET + left&, K2~& ELSE _MEMPUT m, m.OFFSET + left&, KLR
  31.                     left& = left& + 4
  32.                 LOOP
  33.             END IF
  34.  
  35.             'hledam od bodu doleva:        Search to left from point K~&
  36.             left& = T&
  37.             cil& = T& - SIZE& * 4
  38.             IF cil& > 0 THEN
  39.                 DO UNTIL left& = cil&
  40.                     KLR = _MEMGET(s, s.OFFSET + left&, _UNSIGNED LONG)
  41.                     IF KLR <> K2~& AND KLR <> K~& THEN _MEMPUT m, m.OFFSET + left&, K2~& ELSE _MEMPUT m, m.OFFSET + left&, KLR
  42.                     left& = left& - 4
  43.                 LOOP
  44.             END IF
  45.  
  46.             'hledam od bodu nahoru         Search to up from point K~&
  47.             left& = T&
  48.             cil& = T& - (_WIDTH(D&) * 4 * SIZE&)
  49.             W& = _WIDTH(D&) * 4
  50.  
  51.             IF cil& > 0 THEN
  52.                 DO UNTIL left& = cil&
  53.                     KLR = _MEMGET(s, s.OFFSET + left&, _UNSIGNED LONG)
  54.                     IF KLR <> K2~& AND KLR <> K~& THEN _MEMPUT m, m.OFFSET + left&, K2~& ELSE _MEMPUT m, m.OFFSET + left&, KLR
  55.                     left& = left& - W&
  56.                 LOOP
  57.             END IF
  58.  
  59.             'hledam od bodu dolu            Search to down from point K~&
  60.             left& = T&
  61.             cil& = T& + (_WIDTH(D&) * 4 * SIZE&)
  62.             IF cil& < s.SIZE THEN
  63.                 DO UNTIL left& = cil&
  64.                     KLR = _MEMGET(s, s.OFFSET + left&, _UNSIGNED LONG)
  65.                     IF KLR <> K2~& AND KLR <> K~& THEN _MEMPUT m, m.OFFSET + left&, K2~& ELSE _MEMPUT m, m.OFFSET + left&, KLR
  66.                     left& = left& + W&
  67.                 LOOP
  68.             END IF
  69.         END IF
  70.         T& = T& + 4
  71.     LOOP
  72.     _MEMFREE m
  73.     _MEMFREE s
  75.  

Title: Re: Bounded font
Post by: Dav on February 27, 2021, 03:10:22 pm
Hi @Petr!  Thanks for posting it.   I like useful code snippets like this.

- Dav
Text Only | Text with Attachments