2013-06-21 16:34

     $TYPECHECK ON

     CONST BMPI_RGB = 0
     CONST BMPI_RLE8 = 1
     CONST BMPI_RLE4 = 2

     TYPE BMPHEADER
      Signature AS STRING*2
      FileSize AS INTEGER
      reserved AS INTEGER
      DataOffset AS INTEGER
      Size AS INTEGER
      Width AS INTEGER
      Height AS INTEGER
      Planes AS WORD
      BitCount AS WORD
      Compression AS INTEGER
      ImageSize AS INTEGER
      XpixelsPerM AS INTEGER
      YpixelsPerM AS INTEGER
      ColorsUsed AS INTEGER
      ColorsImportant AS INTEGER
     END TYPE

     DIM BMPINFOHEADER AS BMPHEADER
     DIM BMPFILESTREAM AS QFILESTREAM


     TYPE QBMPINFO EXTENDS QOBJECT
      Info AS bmpheader
      Palette AS QPANEL
      PM AS QMEMORYSTREAM
      PColor(255) AS QLABEL

'______________________________________________________________________________
      SUB GeneratePalette

       WITH QBMPINFO.palette
        .width = 160
        .height = 160
        .borderstyle = 0
       END WITH

'Dim PColor(255) as qlabel
       DIM px AS INTEGER
       DIM tmpcol AS INTEGER


       px = 0
       QBMPINFO.PM.position = 0


       DO
        QBMPINFO.Pcolor(px).PARENT = QBMPINFO.Palette
        QBMPINFO.Pcolor(px).autosize = 0
        QBMPINFO.Pcolor(px).width = 10
        QBMPINFO.Pcolor(px).height = 10
        QBMPINFO.Pcolor(px).COLOR = 255 * px
        QBMPINFO.Pcolor(px).top = 10 * FLOOR((px / 16))
        QBMPINFO.Pcolor(px).left = 10 * (px MOD 16)
        QBMPINFO.Pcolor(px).COLOR = QBMPINFO.PM.readnum(4)
        INC(px)
       LOOP UNTIL px = 256


      END SUB
'______________________________________________________________________________
      SUB OPEN (File AS STRING)
       IF FILEEXISTS(File) = 0 THEN
        SHOWMESSAGE "File not found"
        EXIT SUB
       END IF

       BMPFILESTREAM.OPEN (File, 0)
       BMPFILESTREAM.position = 0
       BMPFILESTREAM.readUDT(QBMPINFO.Info)

       IF QBMPINFO.Info.Bitcount <= 8 THEN
        DIM ncolors AS INTEGER
        DIM rwbyte AS BYTE
        DIM rwint AS INTEGER
        DIM x AS INTEGER

        x = 0
        ncolors = 2 ^ QBMPINFO.Info.Bitcount
        ncolors = ncolors * 4

        DO
         rwint = 0
         rwbyte = BMPFILESTREAM.readnum(1)
         rwint = rwint + (rwbyte * 65536)
         rwbyte = BMPFILESTREAM.readnum(1)
         rwint = rwint + (rwbyte * 256)
         rwbyte = BMPFILESTREAM.readnum(1)
         rwint = rwint + rwbyte
         rwbyte = BMPFILESTREAM.readnum(1)
         QBMPINFO.PM.writenum(rwint, 4)
         INC(x)
        LOOP UNTIL x = ncolors

       END IF

       BMPFILESTREAM.CLOSE


       QBMPINFO.GeneratePalette
       QBMPINFO.PM.CLOSE

      END SUB
'______________________________________________________________________________
      WITH QBMPINFO.Info
       FUNCTION Signature AS STRING        :Result = .signature        : END FUNCTION
       FUNCTION FileSize AS INTEGER        :Result = .Filesize         : END FUNCTION
       FUNCTION Reserved AS INTEGER        :Result = .Reserved         : END FUNCTION
       FUNCTION DataOffset AS INTEGER      :Result = .DataOffset       : END FUNCTION
       FUNCTION Size AS INTEGER            :Result = .Size             : END FUNCTION
       FUNCTION Width AS INTEGER           :Result = .Width            : END FUNCTION
       FUNCTION Height AS INTEGER          :Result = .Height           : END FUNCTION
       FUNCTION Planes AS WORD	            :Result = .Planes	        : END FUNCTION
       FUNCTION BitCount AS WORD	        :Result = .BitCount	        : END FUNCTION
       FUNCTION Compression AS INTEGER	    :Result = .Compression	    : END FUNCTION
       FUNCTION ImageSize AS INTEGER	    :Result = .ImageSize	    : END FUNCTION
       FUNCTION XpixelsPerM AS INTEGER	    :Result = .XpixelsPerM	    : END FUNCTION
       FUNCTION YpixelsPerM AS INTEGER	    :Result = .YpixelsPerM	    : END FUNCTION
       FUNCTION ColorsUsed AS INTEGER	    :Result = .ColorsUsed	    : END FUNCTION
       FUNCTION ColorsImportant AS	INTEGER	:Result = .ColorsImportant  : END FUNCTION
      END WITH
'______________________________________________________________________________
      FUNCTION Numcolors AS INTEGER
       Result = 2 ^ QBMPINFO.Info.Bitcount
      END FUNCTION
'______________________________________________________________________________

     END TYPE

2013-06-21 16:34