SaveIcon32 - mkilgore/QB64pe GitHub Wiki

IF...THEN mode% = 0 THEN CLS , _RGB(255, 255, 255)
IF...THEN clrmode% = 256 THEN _COPYPALETTE (img&)
_PUTIMAGE (0, 0)-(size& - 1, size& - 1), img&, 0 '(31, 31), img&, 0  '<<<<<<<<<<<

LOCATE 20, 10: PRINT "Do you want to make an icon out of the image? (Y/N) ";
K$ = INPUT$(1): PRINT K$
IF...THEN UCASE$(K$) <> "Y" THEN END
SaveFile$ = LEFT$(BMP$, INSTR(BMP$, ".")) + "ico"
SaveIcon32 img&, size&, mode%, SaveFile$

END 
'             ---------------------------------------------------------

SUB SaveIcon32 (image AS LONG, size AS LONG, mode AS INTEGER, filename AS STRING)
bytesperpixel& = _PIXELSIZE(image&)
IF...THEN bytesperpixel& = 0 THEN PRINT "Text modes unsupported!": END
IF...THEN bytesperpixel& = 1 THEN bpp& = 8 ELSE bpp& = 24 '256 or 32 bit color
IF...THEN size& MOD 16 OR size& < 16 OR size& > 128 THEN PRINT "Size not supported!": END
x& = size& 'supports sizes from 16 to 128 only!
y& = size&
'Headers:   icon    count   width    depth    colors          cursor hotspots  size - offset
b$= MKI$(0)+MKI$(1)+MKI$(1)+CHR$(x&)+CHR$(y&)+CHR$(0)+CHR$(0)+MKI$(0)+MKI$(0)+"????"+MKL$(22) _
 +MKL$(40)+MKL$(x&)+MKL$(2 * y&)+MKI$(1)+MKI$(bpp&)+MKL$(0)+"????" + STRING$(16, 0)
'BMP size  width   double height  plane     BPP             raw size
IF...THEN bytesperpixel& = 1 THEN
  FOR...NEXT c& = 0 TO 255 ' read BGR color settings from image + 1 byte spacer(CHR$(0))
    cv& = _PALETTECOLOR (function)(c&, image&) ' color attribute to read.
    b$ = b$ + CHR$(_BLUE32(cv&)) + CHR$(_GREEN32(cv&)) + CHR$(_RED32(cv&)) + CHR$(0) 'spacer
  NEXT
END IF
lastsource& = _SOURCE
_SOURCE 0 'set source as program screen. Do NOT use loaded image handle as size has changed!
IF...THEN ((x& * 3) MOD 4) THEN padder$ = STRING$(4 - ((x& * 3) MOD 4), 0)
FOR...NEXT py& = y& - 1 TO 0 STEP -1 ' read target image pixel color data
  r$ = ""
  FOR...NEXT px& = 0 TO x& - 1
    c& = POINT(px&, py&)
    IF...THEN bytesperpixel& = 1 THEN r$ = r$ + CHR$(c&) ELSE r$ = r$ + LEFT$(MKL$(c&), 3)
  NEXT px&
  d$ = d$ + r$ + padder$
NEXT py&
IF...THEN (x& MOD 32) THEN bitpad& = 32 - (x& MOD 32) 'padder bits when not multiples of 32
IF...THEN mode% THEN 'make black pixels white in AND mask so they become transparent
  FOR...NEXT py& = y& - 1 TO 0 STEP -1 'read image to find black pixels
    px& = 0
    DO...LOOP: byte% = 0
      FOR...NEXT bit% = 7 TO 0 STEP -1 'change transparent color to suit your needs
        byte% = 2 * byte% - (POINT(px&, py&) = _RGB(0, 0, 0)) 'bitpacking adds 1 when true
        px& = px& + 1
      NEXT
      a$ = a$ + CHR$(byte%)
    LOOP WHILE px& < x& - 1
    IF...THEN bitpad& THEN a$ = a$ + STRING$((bitpad& + 7) \ 8, 0) 'add padder at end of row when necessary
  NEXT
ELSE a$ = STRING$(y& * ((x& + bitpad& + 7) \ 8), 0) 'totally black AND (boolean) mask
END IF
d$ = d$ + a$
_SOURCE lastsource&
MID$(b$, 43, 4) = MKL$(LEN(d$)) 'raw image size with AND mask
b$ = b$ + d$ ' total file data bytes to create file
MID$(b$, 15, 4) = MKL$(LEN(b$) - 22) ' size of data file minus Entry header offset
IF...THEN LCASE$(RIGHT$(filename$, 4)) <> ".ico" THEN ext$ = ".ico"
f& = FREEFILE
OPEN filename$ + ext$ FOR...NEXT OUTPUT AS #f&: CLOSE #f& ' erases an existing file
OPEN filename$ + ext$ FOR...NEXT BINARY AS #f&
PUT #f&, , b$
CLOSE #f&
END SUB '' ''