POINT Software Programming/PPROG1.ISO/basic/bmag/icoicns.bas

BASIC Source File | 1994-04-26 | 5.6 KB | 171 lines

'─ Area: F-QUICKBASIC ─────────────────────────────────────────────────────────
'  Msg#: 438                                          Date: 14 Apr 94  00:22:00
'  From: Howard Hull Jr                               Read: Yes    Replied: No
'    To: Mae Taylor                                   Mark:
'  Subj: *.Icos To *.Icns      1/2
'──────────────────────────────────────────────────────────────────────────────
'   Mae, here is a sub that will open a .ICO file display it on screen.
'Once on screen it can be BSAVEd to disk, then all you would have to
'do is BLOAD the new file and display it where ever you wish.
'You could also include a DIR$ routine that would read entire directories
'of icons displaying each, change the file name from ICONFILE.ICO to
'ICONFILE.ICN, and then BSAVE it.


 '******* CODE START
 DECLARE SUB Convert (IconFileName$) DEFINT A-Z
'Don't leave home without it '----- TYPE DECLARATIONS TYPE IconDirEntry
   idWide AS STRING * 1          'In pixels (16, 32, 64)
   idHigh AS STRING * 1          'In pixels (16, 32, 64)
   idColorCount AS STRING * 1    'Number of colors (2, 8, 16)
   idReserved AS STRING * 1
   idPlanes AS INTEGER           'Number of color planes
   idBitCount AS INTEGER         'Number of bits in icon
   idBytesInRes AS LONG          'Size of Icon in bytes
   idImageOffset AS LONG         'Offset to image data
END TYPE

TYPE IconDir
   idReserved AS INTEGER         'Always Zero
   idType AS INTEGER             'Usually set to 1
   idCount AS INTEGER            'Number of entries in directory
   idEntries  AS IconDirEntry
END TYPE

TYPE BitMapInfoHeader
   biSize AS LONG                'Number bytes in header
   biWide AS LONG                'In pixels
   biHigh AS LONG                'In pixels
   biPlanes AS INTEGER           'Set to 1
   biBitCount AS INTEGER         'Bits per pixel (1,4,8,24)
   biCompress AS LONG            'RGB or RLE4, RLE8
   biImageSize AS LONG           'In Bytes. Can be 0 if RGB
   biXpels AS LONG               'Target device
   biYpels AS LONG               'Target device
   biColrUsed AS LONG            'Used in Color table. 0=Max
   biColrImportant AS LONG       '0=All
END TYPE

TYPE RGBQuad
   rgbBlue AS STRING * 1         'Range 0 to 255
   rgbGreen AS STRING * 1
   rgbRed AS STRING * 1
   rgbReserved AS STRING * 1
END TYPE

TYPE ImageXOR
   icXOR AS STRING * 1
END TYPE

TYPE ImageAND
   icAND AS STRING * 1
END TYPE

'----- HOUSEKEEPING
DIM SHARED icID AS IconDir
DIM SHARED bmID AS BitMapInfoHeader

SCREEN 12
CALL Convert(IconFile$, NewFile$, 100, 100)
SCREEN 0
END


SUB Convert (IconFileName$, TLine, LEdge)
'----- ICON FILE HANDLING              'Put your input routine here
IconFile = FREEFILE
OPEN IconFileName$ FOR BINARY AS IconFile

NewFile$ = GetNewFile$(IconFileName$)
'----- GET ICON INFORMATION
GET #IconFile, , icID
LOCATE 1, 1: PRINT "ICON: " + IconFileName$; "  =>   "; NewFile$
LOCATE 2, 1: PRINT "Sizes - File:" + STR$(LOF(IconFile));
             PRINT " Resource:"; icID.idEntries.idBytesInRes
LOCATE 3, 1: PRINT " Icon - W:"; ASC(icID.idEntries.idWide);
             PRINT "x H:"; ASC(icID.idEntries.idHigh);
             PRINT "Colors:"; ASC(icID.idEntries.idColorCount)

'----- THIS ROUTINE WILL READ 766 BYTE ICON FILE ONLY.
'----- ALTHOUGH IT CAN BE MODIFIED FOR WINDOWS .DLL FILES
'----- AND .EXE FILES THAT ALSO CONTAIN ICONS. I DON'T
'----- YET HAVE THE INFORMATION TO DO THIS.
IF LOF(IconFile) <> 766 THEN CLOSE IconFile: EXIT SUB

'----- GET BITMAP INFORMATION
GET #IconFile, , bmID
LOCATE 4, 1: PRINT "Bits/Pixel:"; bmID.biBitCount

'----- LOAD COLOR TABLE
REDIM ColrTbl(1 TO ASC(icID.idEntries.idColorCount)) AS RGBQuad
FOR i = LBOUND(ColrTbl) TO UBOUND(ColrTbl)
   GET #IconFile, , ColrTbl(i)
NEXT i

'----- LOAD IMAGE XOR TABLE
TblSize = (ASC(icID.idEntries.idWide) * ASC(icID.idEntries.idHigh)) \ 2
REDIM XORTbl(1 TO TblSize) AS ImageXOR
   FOR i = 1 TO UBOUND(XORTbl)
      GET #IconFile, , XORTbl(i)
   NEXT i

'----- LOAD IMAGE AND TABLE
TblSize = (ASC(icID.idEntries.idWide) * ASC(icID.idEntries.idHigh)) \ 8
REDIM ANDTbl(1 TO TblSize) AS ImageAND
   FOR i = 1 TO UBOUND(ANDTbl)
      GET #IconFile, , ANDTbl(i)
   NEXT i
CLOSE IconFile

'-----
icWide = ASC(icID.idEntries.idWide)
icHigh = ASC(icID.idEntries.idHigh)
REDIM ImageArray(1 TO icHigh, 1 TO icWide) AS INTEGER
TblPtr = UBOUND(ANDTbl)
FOR Row = 1 TO icHigh STEP 1
   FOR Col = icWide TO 1 STEP -8
      FOR i = 0 TO 7
         BitMap = ASC(ANDTbl(TblPtr).icAND)
         IF BitMap AND 2 ^ i THEN
            'Colr = 15
            Colr = 7
         ELSE
            Colr = 0
         END IF
         ImageArray(Col - i, Row) = Colr
      NEXT i
      TblPtr = TblPtr - 1
   NEXT Col
NEXT Row

TblPtr = UBOUND(XORTbl)
FOR Row = 1 TO icHigh STEP 1
   FOR Col = icWide TO 1 STEP -2
         ColrMap = ASC(XORTbl(TblPtr).icXOR)
         Colr = (&HF0 XOR ColrMap) MOD 16
         ImageArray(Col, Row) = ImageArray(Col, Row) XOR Colr
         Colr = (&HF XOR ColrMap) \ 16
         ImageArray(Col - 1, Row) = ImageArray(Col - 1, Row) XOR Colr
         TblPtr = TblPtr - 1
      NEXT Col
NEXT Row

'----- DISPLAY ICON
BLine = TLine + ASC(icID.idEntries.idWide) - 1
REdge = LEdge + ASC(icID.idEntries.idWide) - 1
LINE (116, 68)-(156, 108), 7, BF
FOR Row = 1 TO icHigh
   FOR Col = 1 TO icWide
      PSET ((LEdge - 1) + Row, (TLine - 1) + Col), ImageArray(Row, Col)
   NEXT Col
NEXT Row

' * BSAVE Icon
DIM TempArray(804)
GET (LEdge - 4, TLine - 4)-(REdge + 4, BLine + 4), TempArray(0)
DEF SEG = VARSEG(TempArray(0))
BSAVE NewFile$, VARPTR(TempArray(0)), 804
DEF SEG

END SUB