PureBasic Forums - English

Posted: **Wed Jun 13, 2007 12:08 am**

This code loads 1/4/8-bit RLE PC Paint Pictor files. It is pretty much the same thing I posted the other day in localmotion's pic decoder thread. The only main change is calculating the bytes per line instead of using an increment value for ix. LoadPIC() returns a DIB and LoadPIC_() returns a DDB.

Last edited on 12 June 2007.

Code: Select all

;PlaneInfo
;$01=1 plane, 1 bit per pixel 2 colors
;$02=1 plane, 2 bits per pixel 4 colors (cga mode)
;$04=1 plane, 4 bits per pixel 16 colors
;$11=2 planes, 1 bit per pixel 4 colors
;$12=2 planes, 2 bits per pixel 16 colors (plantronics)
;$31=4 planes, 1 bit per pixel 16 colors (ega mode)
;$08=1 plane, 8 bits per pixel 256 colors (vga mode)
;$10=1 plane, 16 bits per pixel 2^16 colors
;$18=1 plane, 24 bits per pixel 2^24 colors
;$28=3 planes, 8 bits per pixel 2^24 colors

;- Structures

Structure PICHEADER
 Id.w ;Magic number (always $1234)
 Width.w ;Width of image in pixels
 Height.w ;Height of image in pixels
 XOffset.w ;X of lower left corner of image
 YOffset.w ;Y of lower left corner of image
 PlaneInfo.b ;BPP and number color planes
 PaletteFlag.b ;Color palette/video flag
 VideoMode.b ;Video mode of image
 PaletteType.w ;Type of color palette
 PaletteSize.w ;Size of color palette
EndStructure

Procedure.l LoadPIC(filename.s)
 ;From "Pictor PC Paint File Format Summary"
 ;Loads 1/4/8-bit RLE Pictor PC Paint files
 
 Protected ph.PICHEADER
 Protected *dib.BITMAPINFOHEADER
 Protected *map.BYTE,*pal.RGBQUAD,*bits.BYTE
 Protected file.l,bitcount.l,planes.l,width.l,height.l,pitch.l
 Protected bhsize.l,ncolors.l,hDIB.l,cmap.l,count.l,nblocks.l
 Protected line.l,ix.l,iy.l,id.l,size.l,length.l,marker.l,pixel.l
 
 ;Open the file
 file=ReadFile(#PB_Any,filename)
 If file=0
  MessageRequester("LOAD ERROR","File could not be opened")
  ProcedureReturn #False
 EndIf
 
 ;Read the pic header
 ReadData(file,ph,SizeOf(PICHEADER))
 
 If ph\Id<>$1234 ;Verify pic header marker
  CloseFile(file)
  MessageRequester("LOAD ERROR","Not a Pictor PC Paint file")
  ProcedureReturn #False
 EndIf
 
 ;Calculate some information
 bitcount=ph\PlaneInfo & 15
 planes=((ph\PlaneInfo & 240) >> 4)+1
 If ph\PlaneInfo=16 Or ph\PlaneInfo=24 ;Hicolor/Truecolor formats
  bitcount=ph\PlaneInfo
  planes=1
 EndIf
 width=ph\Width & $FFFF
 height=ph\Height & $FFFF
 line=((width*bitcount)+7)/8 ;Bytes per line
 pitch=(((width*bitcount)+31)/32)*4 ;DWORD-aligned width
 bhsize=SizeOf(BITMAPINFOHEADER) ;DIB info header size 
 ncolors=0 ;No DIB palette
 If bitcount*planes<16
  ncolors=1 << bitcount ;2/16/256 colors
 EndIf
 
 ;Allocate the DIB
 hDIB=AllocateMemory(bhsize+(ncolors*4)+(pitch*height))
 If hDIB=0
  CloseFile(file)
  MessageRequester("LOAD ERROR","Memory allocation failed")
  ProcedureReturn #False
 EndIf
 
 ;Fill in the DIB info header
 *dib=hDIB ;Pointer to DIB
 With *dib
  \biSize=SizeOf(BITMAPINFOHEADER)
  \biWidth=width
  \biHeight=height
  \biPlanes=1
  \biBitCount=bitcount
  \biCompression=#BI_RGB
  \biSizeImage=pitch*height
  \biXPelsPerMeter=0
  \biYPelsPerMeter=0
  \biClrUsed=ncolors
  \biClrImportant=0
 EndWith
 
 cmap=AllocateMemory(ph\PaletteSize+1) ;Allocate the pic palette
 If cmap=0
  FreeMemory(hDIB)
  CloseFile(file)
  MessageRequester("LOAD ERROR","Memory allocation failed")
  ProcedureReturn #False
 EndIf
 
 ReadData(file,cmap,ph\PaletteSize) ;Read the pic palette
 
 ;Fill in the DIB palette
 *map=cmap ;Pointer to pic palette
 *pal=hDIB+bhsize ;Pointer to DIB palette 
 If ph\PaletteType<=2 ;No palette=0, CGA=1 or PC Jr/non-ECD=2
  For count=0 To ncolors-1 ;Build a greyscale palette
   *pal\rgbBlue=((255*count)/(ncolors-1)) & 255 ;blue
   *pal\rgbGreen=((255*count)/(ncolors-1)) & 255 ;green
   *pal\rgbRed=((255*count)/(ncolors-1)) & 255 ;red
   *pal+4
  Next
 ElseIf ph\PaletteType=3 ;EGA palette, 0..63
  For count=0 To ph\PaletteSize-1
   If *map\b & $01 : *pal\rgbBlue+$80 : EndIf
   If *map\b & $02 : *pal\rgbGreen+$80 : EndIf
   If *map\b & $04 : *pal\rgbRed+$80 : EndIf
   If *map\b & $08 : *pal\rgbBlue+$40 : EndIf
   If *map\b & $10 : *pal\rgbGreen+$40 : EndIf
   If *map\b & $20 : *pal\rgbRed+$40 : EndIf
   *pal+4 : *map+1
  Next
 ElseIf ph\PaletteType=4 ;VGA palette, 0..63
  For count=0 To (ph\PaletteSize/3)-1
   *pal\rgbRed=*map\b << 2 : *map+1 ;red
   *pal\rgbGreen=*map\b << 2 : *map+1 ;green
   *pal\rgbBlue=*map\b << 2 : *map+1 ;blue
   *pal+4
  Next
 EndIf
 
 FreeMemory(cmap) ;Free the pic palette
 
 nblocks=ReadWord(file) & $FFFF ;Get the number of blocks in file
 
 ;Read the data
 Select nblocks
 
  Case 0 ;Uncompressed pic
  
  Default ;RLE-compressed pic
  
   ix=0 ;Reset
   iy=0
   *bits=hDIB+bhsize+(ncolors*4)+(pitch*iy)
   
   For id=0 To nblocks-1
   
    size=ReadWord(file) & $FFFF ;Entire size of this block
    length=ReadWord(file) & $FFFF ;Size of unpacked pixel data
    marker=ReadByte(file) & 255 ;Marker for start of a run
    count=0 ;Reset the run count
    
    While length>0
     If count>0 ;RLE pixels
      length-1
      count-1
      *bits\b=pixel
      *bits+1
      ix+1
     Else ;Get the next packet
      pixel=ReadByte(file) & 255 ;Run marker or pixel value
      If pixel=marker
       count=ReadByte(file) & 255 ;8-bit run length
       If count>0
        pixel=ReadByte(file) & 255 ;Pixel value
       Else
        count=ReadWord(file) & $FFFF ;16-bit run length
        pixel=ReadByte(file) & 255 ;Pixel value
       EndIf
      Else ;Non-RLE pixels
       length-1
       *bits\b=pixel
       *bits+1
       ix+1
      EndIf
     EndIf
     If ix>=line ;We've reached the end of a scanline
      ix=0
      iy+1
      If iy>=height : Break : EndIf
      *bits=hDIB+bhsize+(ncolors*4)+(pitch*iy)
     EndIf
    Wend
    
   Next
   
 EndSelect
 
 CloseFile(file) ;Close the file
 ProcedureReturn hDIB
 
EndProcedure

Procedure.l LoadPIC_(filename.s)

 Protected *dib.BITMAPINFOHEADER
 Protected bits.l,hDC.l,hBitmap.l
 
 *dib=LoadPIC(filename)
 If *dib=0 ;Avoid errors
  ProcedureReturn #False
 EndIf
 
 bits=*dib+*dib\biSize+(*dib\biClrUsed*4) ;Pointer to bits
 
 ;Create the DDB bitmap
 hDC=GetDC_(#Null)
 hBitmap=CreateDIBitmap_(hDC,*dib,#CBM_INIT,bits,*dib,#DIB_RGB_COLORS)
 
 FreeMemory(*dib) ;Free the DIB
 ProcedureReturn hBitmap
 
EndProcedure

If OpenWindow(0,0,0,640,480,"Load PIC",#PB_Window_SystemMenu | #PB_Window_ScreenCentered) And CreateGadgetList(WindowID(0))
 ButtonGadget(0,10,10,80,20,"Open File")
 ImageGadget(1,10,50,300,300,0,#PB_Image_Border)
EndIf

Repeat
 Select WaitWindowEvent()
  Case #PB_Event_Gadget
   Select EventGadget()
    Case 0
     Pattern.s="All Supported Formats|*.pic"
     filename.s=OpenFileRequester("Choose An Image File To Open","",Pattern,0)
     If filename
      hBitmap.l=LoadPIC_(filename)
      SendMessage_(GadgetID(1),#STM_SETIMAGE,#IMAGE_BITMAP,hBitmap)
     EndIf
   EndSelect
  Case #PB_Event_CloseWindow
   End
 EndSelect
ForEver

PureBasic Forums - English

LoadPIC Procedure

LoadPIC Procedure