home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / basic / baswiz19 / examples / g13makeb.bas < prev    next >
Encoding:
BASIC Source File  |  1993-01-31  |  2.3 KB  |  57 lines
  1. '   +----------------------------------------------------------------------+
  2. '   |                                                                      |
  3. '   |        BASWIZ  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4. '   |                                                                      |
  5. '   |                      The BASIC Wizard's Library                      |
  6. '   |                                                                      |
  7. '   +----------------------------------------------------------------------+
  8.  
  9.    DECLARE SUB FOpen (File$, FMode$, BufferLen%, Handle%, ErrCode%)
  10.    DECLARE SUB FBlockWrite (BYVAL Handle%, BYVAL Segm%, BYVAL Ofs%, BYVAL Bytes%)
  11.    DECLARE FUNCTION FGetError% (BYVAL Handle%)
  12.    DECLARE SUB FWrite (BYVAL Handle%, St$)
  13.    DECLARE SUB FClose (Handle%)
  14.    DECLARE FUNCTION G13GetPel% (BYVAL X%, BYVAL Y%)
  15.    DECLARE SUB VGetPalette (BYVAL PalReg%, Red%, Green%, Blue%)
  16.  
  17.    DECLARE SUB PalBlk1 (BYVAL DSeg%, BYVAL DOfs%, BYVAL Colors%)
  18.  
  19. SUB G13MakeBMP (File$, X1%, Y1%, X2%, Y2%, ErrCode%)
  20.    PicWidth% = (X2% - X1%) + 1
  21.    PicHeight% = (Y2% - Y1%) + 1
  22.    IF PicWidth% > 0 AND PicHeight% > 0 THEN
  23.       ErrCode% = 0
  24.       FOpen File$, "CW", 0, Handle%, ErrCode%
  25.    ELSE
  26.       ErrCode% = -5
  27.    END IF
  28.    IF ErrCode% = 0 THEN
  29.       WidthFiller% = ((PicWidth% + 3) \ 4) * 4 - PicWidth%
  30.       FileSize& = 1078& + CLNG(PicWidth% + WidthFiller%) * CLNG(PicHeight%)
  31.       FWrite Handle%, "BM" + MKL$(FileSize&) + MKL$(0) + MKL$(1078) + MKL$(40) + MKL$(PicWidth%) + MKL$(PicHeight%) + MKI$(1) + MKI$(8) + STRING$(6 * 4, 0)
  32.       ErrCode% = FGetError%(Handle%)
  33.  
  34.       '----- write the palette -----
  35.       DIM Pal&(0 TO 255)
  36.       DSeg% = VARSEG(Pal&(0))
  37.       DOfs% = VARPTR(Pal&(0))
  38.       PalBlk1 DSeg%, DOfs%, 256
  39.       FBlockWrite Handle%, DSeg%, DOfs%, 256 * 4
  40.  
  41.       '----- write the image -----
  42.       IF ErrCode% = 0 THEN
  43.          St$ = STRING$(PicWidth% + WidthFiller%, 0)
  44.          FOR y% = Y2% to Y1% step -1
  45.             FOR x% = X1% TO X2%
  46.                MID$(St$, x% - X1% + 1, 1) = CHR$(G13GetPel(x%, y%))
  47.             NEXT
  48.             FWrite Handle%, St$
  49.             ErrCode% = FGetError%(Handle%)
  50.             IF ErrCode% THEN EXIT FOR
  51.          NEXT
  52.       END IF
  53.  
  54.       FClose Handle%
  55.    END IF
  56. END SUB
  57.