unit PCX256; { PCX256.PAS unit version 1.0 Reinout Raymakers 1997 }
{
When I was looking for a screen-export routine in TP 7.0 that writes
the picture in a wide-spread file format such as PCX, BMP or GIF, I could
not find anything that was both understandably and bugfree...
The only working routines contained assembler code, so that i could not
change the routines to fit my purpose. I then decided to do it from scratch
and here's the result (completely assembler-free and still quite fast):
This unit reads and writes 256 color .PCX files. Keep the following things
in mind:
- Files are only written correctly if the computer is in 256 color
mode using a .BGI file (e.g. SVGA256.BGI), because this unit
uses the graph unit to read and write pixels.
The routines also work in 16 color mode, but unless you carefully
define your colors (SetRGBPalette procedure), the colors of
the picture can turn out the wrong way......
- The procedures do not check if files exist, or if the files you
specify are indeed correct PCX files. You have to do that in
the main program yourself. (You can use CheckPCX256 to do that.)
- 'FileName' should always contain the extension of the file.
You are free to use or change this unit in any way you like, but I would
appreciate it, if you mailed me your suggestions / changes / bugs or
anything else you want changed....
P.S. Except for the SetVGAPalette, GetVGAPalette & FileExists routines, all
the code is written by me. The FileExists routine is from the Help
of Turbo Pascal. I don't remember where I got the other two routines,
but hereby I want to thank the authors, because I'm really bad
at low-level memory coding....
Reinout Raymakers
Nolensstraat 12
5344 SK Oss
The Netherlands
reinoutr@sci.kun.nl
RR, 18 May 1997
Projects that I'm still working on: - True color (24 bit) PCX files unit
- Export routines for GIF / BMP formats
}
interface
type Colorvalue = Record
Rvalue,
Gvalue,
Bvalue : byte;
end;
Palette16 = Array [0..15] of Colorvalue;
Palette256 = Array [0..255] of Colorvalue;
PCXType = Object { Header definition of .PCX file }
ID, { Manufacturer, 10 = ZSoft }
Version, { Version, 5 = latest }
Encoding, { Compression, 1 = RLE }
BPP : Byte; { Bits per pixel, 8 for 256 colors }
Window : Record { Original position and size of picture }
Left, { X1 }
Top, { Y1 }
Right, { X2 }
Bottom : Word { Y2 }
End;
HorRes,
VerRes : Word; { Physical properties of picture, in DPI }
Colors : Palette16; { 16 color palette, unused at 256 colors }
Reserved, { Reserved Byte }
NPlanes : Byte; { Number of planes, 1 for 256 colors }
BPL, { Bytes per horizontal line }
Palette : Word; { Greyscale or Color, 1 for Color (2 for Grayscale) }
Filler : Array[1..58] of Byte; { Reserved space }
End;
procedure WritePCX256(FileName : String; X1, Y1, X2, Y2 : Word);
{ FileName is the name of the file you want to write the data to, X1, Y1, X2
and X2 are the coordinates of the window your want to write to disk. }
procedure ReadPCX256(FileName : String; X, Y : Word);
{ FileName is the name of the file you want to read the data from. X and Y
are the coordinates at which position you want the upper left corner of the
picture.}
procedure InfoPCX(FileName : String; var Header : PCXType);
{ FileName is the name of the file you want info about. This procedure does
nothing but give the header of the .PCX file in the variable Header. }
function CheckPCX256(FileName : String; var Error : Byte) : Boolean;
{ FileName is the name of the file of which you want to be sure that it is
a correct 256 color .PCX file. CheckPCX256 returns TRUE if the file is
indeed such a file. If NOT, it returns FALSE.
'Error' contains more detailed information on what the problem is:
0 - file is ok
1 - file does not exist
2 - file is not a PCX file
3 - file is PCX, but not a 256 color file
4 - file is 256 color PCX, but the data compression type is unknown
(you can always try to read it anyway, it might be an error in the
header, because for PCX only RLE is documented!)
}
implementation
uses Dos, MyUnit;
const BufferSize = 4096; { Size of the buffer for reading and writing files }
procedure GetVGAPalette(var Pal : Palette256);
var ColorNo : Byte;
begin
for ColorNo := 0 to 255 do
begin
Port [$3c7] := ColorNo;
Pal[ColorNo].RValue := Port [$3c9];
Pal[ColorNo].GValue := Port [$3c9];
Pal[ColorNo].BValue := Port [$3c9];
end;
end; { GetVGAPalette }
procedure SetVGAPalette(var Pal : Palette256);
var Regs : Registers;
begin
with Regs do
begin
AX:=$1012;
BX:=0;
CX:=256;
ES:=Seg(Pal); DX:=Ofs(Pal);
end;
Intr($10,Regs);
end; { SetVGAPalette }
function FileExists(FileName: String): Boolean;
var
F: File;
begin
{$I-}
Assign(F, FileName);
Reset(F);
Close(F);
{$I+}
FileExists := (IOResult = 0) and (FileName <> '');
end; { FileExists }
procedure WritePCX256;
var Header : PCXType;
PCXFile : File;
Pal256 : Palette256;
procedure OpenFile;
begin
Assign(PCXFile,FileName);
ReWrite(PCXFile,1);
end;
procedure WriteHeader;
begin
with Header do
begin
ID := 10;
Version := 5;
Encoding := 1;
BPP := 8;
with Window do
begin
Left := X1;
Top := Y1;
Right := X2;
Bottom := Y2;
end;
HorRes := 300; { Since a picture that is written from the screen has no }
VerRes := 300; { physical size, 300 DPI is just a random chosen value... }
NPlanes := 1;
BPL := X2-X1+1;
{ If Odd(BPL) then Inc(BPL); } { Officially BPL should always be even, but
after implementation, a lot of programs
could not read the files anymore, and
this solution does not seem to give any
problems..... }
Palette := 1;
end;
BlockWrite(PCXFile,Header,SizeOf(Header));
end;
procedure WriteData; { This procedure writes a RLE compressed picture. }
var X, Y : Word;
Buffer : Array[0..BufferSize] of Byte;
Count : Word;
CurColor,
ByteCnt,
Color : Byte;
begin
For Y := Y1 to Y2 do
begin
Count := 0;
ByteCnt := 0;
For X := X1 to X2 do
begin
Color := GetPixel(X,Y);
If X = X1 then { just remember the first byte }
begin
CurColor := Color;
ByteCnt := 1;
end
else
begin
If (Color <> CurColor) OR (ByteCnt = 63) then { write data if new color or more than 63 the same }
begin
If (ByteCnt <> 1) or (CurColor AND $C0 = $C0) then { write RLE code if necessary }
begin
Buffer[Count] := ByteCnt OR $C0;
Inc(Count);
end;
Buffer[Count] := CurColor; { write color }
Inc(Count);
CurColor := Color;
ByteCnt := 1;
end
else
begin
Inc(ByteCnt);
end;
end;
If X = X2 then { write buffer to file after last byte }
begin
Buffer[Count] := ByteCnt OR $C0;
Inc(Count);
Buffer[Count] := CurColor;
Inc(Count);
BlockWrite(PCXFile,Buffer,Count);
end;
end;
end;
end;
procedure WritePalette;
Var Marker,
Count : Byte;
begin
Marker := 12;
GetVGAPalette(Pal256);
For Count := 0 to 255 do
begin
Pal256[Count].RValue := Pal256[Count].RValue * 4;
Pal256[Count].BValue := Pal256[Count].BValue * 4;
Pal256[Count].GValue := Pal256[Count].GValue * 4;
end;
BlockWrite(PCXFile,Marker,SizeOf(Marker));
Blockwrite(PCXFile,Pal256,SizeOf(Pal256));
end;
procedure CloseFile;
begin
Close(PCXFile);
end;
begin
OpenFile; { Create the new file }
WriteHeader; { Create a correct header and write it to file }
WriteData; { Compress data using RLE and write data to file }
WritePalette; { Get current standard VGA palette, convert it to
a 16.7 Million color palette and write it to file }
CloseFile; { And ready is your PCX! }
end; { WritePCX256 }
procedure ReadPCX256;
var Header : PCXType;
PCXFile : File;
Pal256 : Palette256;
X1, Y1 : Word;
procedure OpenFile;
begin
Assign(PCXFile,FileName);
Reset(PCXFile,1);
end;
procedure ReadHeader;
begin
BlockRead(PCXFile,Header,SizeOf(Header));
X1 := X;
Y1 := Y;
end;
procedure ReadPalette;
var Marker,
Count : Byte;
begin
Seek(PCXFile,FileSize(PCXFile) - 769);
BlockRead(PCXFile,Marker,SizeOf(Marker));
BlockRead(PCXFile,Pal256,SizeOf(Pal256));
For Count := 0 to 255 do
begin
Pal256[Count].RValue := Pal256[Count].RValue DIV 4;
Pal256[Count].BValue := Pal256[Count].BValue DIV 4;
Pal256[Count].GValue := Pal256[Count].GValue DIV 4;
end;
SetVGAPalette(Pal256);
end;
procedure ReadData;
var Buffer : Array[0..BufferSize] of Byte;
Count,
Count2 : Word;
Result : Word;
ByteCount : Byte;
BeginX,
BeginY : Word;
Finish : Boolean;
begin
Seek(PCXFile,SizeOf(Header));
BeginY := Y;
BeginX := X;
Finish := FALSE;
repeat
BlockRead(PCXFile,Buffer,BufferSize,Result);
If Result < BufferSize then Finish := TRUE;
If FilePos(PCXFile) > FileSize(PCXFile) - 769 then
begin
Result := Result - (FilePos(PCXFile) - (FileSize(PCXFile) - 769));
Finish := TRUE;
end;
For Count := 0 to Result - 1 do
begin
If Buffer[Count] AND $C0 = $C0 then { check if byte is a RLE code }
begin
If Count = Result - 1 then
begin
Seek(PCXFile,FilePos(PCXFile)-1); { check if we've got the color for that RLE }
end
else
begin
ByteCount := Buffer[Count] - $C0;
Inc(Count);
For Count2 := 1 to ByteCount do { write the number of pixels as stored in the RLE }
begin
If BeginX - X <= Header.Window.Right - Header.Window.Left { don't run of the screen }
then PutPixel(BeginX,BeginY,Buffer[Count]);
Inc(BeginX);
If BeginX >= (X + Header.BPL) then { do we have to go to the next line? }
begin
Inc(BeginY);
BeginX := X;
end;
end;
end;
end
else
begin
If BeginX - X <= Header.Window.Right - Header.Window.Left { identical to the above, but now we only write one pixel }
then PutPixel(BeginX,BeginY,Buffer[Count]);
Inc(BeginX);
If BeginX >= (X + Header.BPL) then
begin
Inc(BeginY);
BeginX := X;
end;
end;
end;
until Finish;
end;
procedure CloseFile;
begin
Close(PCXFile);
end;
begin
OpenFile; { Open the PCX file }
ReadHeader; { Read the header from the file }
ReadPalette; { Read the 16.7 Million color palette from the file,
convert it to standard VGA and apply it }
ReadData; { Read data from file, decompress and put picture on screen }
CloseFile; { Close the file }
end; { ReadPCX256 }
procedure InfoPCX;
var PCXFile : File;
begin
Assign(PCXFile,FileName);
Reset(PCXFile,1);
BlockRead(PCXFile,Header,SizeOf(Header));
Close(PCXFile);
end; { InfoPCX }
function CheckPCX256;
var Header : PCXType;
PCXFile : File;
Result : Word;
Marker : Byte;
begin
CheckPCX256 := TRUE;
Error := 0;
If not FileExists(FileName) then
begin
CheckPCX256 := FALSE;
Error := 1;
end
else
begin
Assign(PCXFile,FileName);
Reset(PCXFile,1);
BlockRead(PCXFile,Header,SizeOf(Header),Result);
Seek(PCXFile,FileSize(PCXFile) - 769);
BlockRead(PCXFile,Marker,SizeOf(Marker),Result);
Close(PCXFile);
If Header.ID <> 10 then
begin
CheckPCX256 := FALSE;
Error := 2;
end
else
begin
If (Marker <> 12) or (Header.BPP <> 8) or (Header.NPlanes <> 1) then
begin
CheckPCX256 := FALSE;
Error := 3;
end;
If (Error = 0) and (Header.Encoding <> 1) then
begin
CheckPCX256 := FALSE;
Error := 4;
end;
end;
end;
end; { CheckPCX256 }
end.
