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