Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Компонент для работы с PCX файлами

01.01.2007

Fully supports reading and writing of: 1, 8 and 24 bit PCX images.

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                           =========                               //
//                                                                   //
// Completed: The 10th of August 2001                                //
// Author:    M. de Haan                                             //
// Email:     M.deHaan@inn.nl                                        //
// Tested:    under W95 SP1, NT4 SP6, WIN2000                        //
// Version:   1.0                                                    //
//-------------------------------------------------------------------//
// Update:    The 14th of August 2001 to version 1.1.                //
// Reason:    Added version check.                                   //
//            Added comment info on version.                         //
//            Changed PCX header ID check.                           //
//-------------------------------------------------------------------//
// Update:    The 19th of August 2001 to version 2.0.                //
// Reason:    Warning from Delphi about using abstract methods,      //
//            caused by not implementing ALL TGraphic methods.       //
//            (Thanks goes to R.P. Sterkenburg for his diagnostic.)  //
// Added:     SaveToClipboardFormat, LoadFromClipboardFormat,        //
//            GetEmpty.                                              //
//-------------------------------------------------------------------//
// Update:    The 13th of October 2001 to version 2.1.               //
// Reason:    strange errors, read errors, EExternalException, IDE   //
//            hanging, Delphi hanging, Debugger hanging, windows     //
//            hanging, keyboard locked, and so on.                   //
// Changed:   Assign procedure.                                      //
//-------------------------------------------------------------------//
// Update:    The 5th of April 2002 to version 2.2.                  //
// Changed:   RLE compressor routine.                                //
// Reason:    Incompatibility problems with other programs caused    //
//            by the RLE compressor.                                 //
//            Other programs encode: $C0 as: $C1 $C0.                //
//            ($C0 means: repeat the following byte 0 times          //
//            $C1 means: repeat the following byte 1 time.)          //
// Changed:   File read routine.                                     //
// Reason:    Now detects unsupported PCX data formats.              //
// Added:     'Unsupported data format' in exception handler.        //
// Added:     1 bit PCX support in reading.                          //
// Added:     Procedure Convert1BitPCXDataToImage.                   //
// Renamed:   Procedure ConvertPCXDataToImage to                     //
//            Convert24BitPCXDataToImage.                            //
//-------------------------------------------------------------------//
// Update:    The 14th of April 2002 to version 2.3.                 //
//            Now capable of reading and writing 1 and 24 bit PCX    //
//            images.                                                //
// Added:     1 bit PCX support in writing.                          //
// Added:     Procedure ConvertImageTo1bitPCXData.                   //
// Changed:   Procedure CreatePCXHeader.                             //
// Changed:   Procedure TPCXImage.SaveToFile.                        //
//-------------------------------------------------------------------//
// Update:    The 19th of April 2002 to version 2.4.                 //
//            Now capable of reading and writing: 1, 8 and 24 bit    //
//            PCX images.                                            //
// Added:     8 bit PCX support in reading and writing.              //
// Renamed:   Procedure ConvertImageTo1And8bitPCXData.               //
// Renamed:   Procedure Convert1And8bitPCXDataToImage.               //
// Changed:   Procedure fSetPalette, fGetPalette.                    //
//-------------------------------------------------------------------//
// Update:    The 7th of May 2002 to version 2.5.                    //
// Reason:    The palette of 8-bit PCX images couldn't be read in    //
//            the calling program.                                   //
// Changed:   Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
// Tested:    All formats were tested with the following programs:   //
//            - import in Word 97,                                   //
//            * (Word ignores the palette of 1 bit PCX images!)      //
//            - import and export in MigroGrafX.                     //
//            * (MicroGrafX also ignores the palette of 1 bit PCX    //
//              images.)                                             //
//            No problems were detected.                             //
//                                                                   //
//===================================================================//
//                                                                   //
//         The PCX image file format is copyrighted by:              //
//           ZSoft, PC Paintbrush, PC Paintbrush plus                //
//                        Trademarks: N/A                            //
//                       Royalty fees: NONE                          //
//                                                                   //
//===================================================================//
//                                                                   //
// The author can not be held responsable for using this software    //
// in anyway.                                                        //
//                                                                   //
// The features and restrictions of this component are:              //
// ----------------------------------------------------              //
//                                                                   //
// The reading and writing (import / export) of files / images:      //
//     - PCX version 5 definition, PC Paintbrush 3 and higher,       //
//     - RLE-compressed,                                             //
//     - 1 and 8 bit PCX images WITH palette and                     //
//     - 24 bit PCX images without palette,                          //
//     are supported by this component.                              //
//                                                                   //
// Known issues                                                      //
// ------------                                                      //
//                                                                   //
// 1) GetEmpty is NOT tested.                                        //
//                                                                   //
// 2) SaveToClipboardFormat is NOT tested.                           //
//                                                                   //
// 3) LoadFromClipboardFormat is NOT tested.                         //
//                                                                   //
// 4) 4 bit PCX images (with palette) are NOT (yet) implemented.     //
//    (I have no 4-bit PCX images to test it on...)                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////
 
unit
 
PCXImage;
 
interface
 
uses
 
Windows,
 
SysUtils,
 
Classes,
 
Graphics;
 
const
  WIDTH_OUT_OF_RANGE
= 'Illegal width entry in PCX file header';
  HEIGHT_OUT_OF_RANGE
= 'Illegal height entry in PCX file header';
  FILE_FORMAT_ERROR
= 'Invalid file format';
  VERSION_ERROR
= 'Only PC Paintbrush (plus) V3.0 and ' +
   
'higher are supported';
  FORMAT_ERROR
= 'Illegal identification byte in PCX file' +
   
' header';
  PALETTE_ERROR
= 'Invalid palette signature found';
  ASSIGN_ERROR
= 'Can only Assign a TBitmap or a TPicture';
  ASSIGNTO_ERROR
= 'Can only AssignTo a TBitmap';
  PCXIMAGE_EMPTY
= 'The PCX image is empty';
  BITMAP_EMPTY
= 'The bitmap is empty';
  INPUT_FILE_TOO_LARGE
= 'The input file is too large to be read';
  IMAGE_WIDTH_TOO_LARGE
= 'Width of PCX image is too large to handle';
 
// added 19/08/2001
  CLIPBOARD_LOAD_ERROR
= 'Loading from clipboard failed';
 
// added 19/08/2001
  CLIPBOARD_SAVE_ERROR
= 'Saving to clipboard failed';
 
// added 14/10/2001
  PCX_WIDTH_ERROR
= 'Unexpected line length in PCX data';
  PCX_HEIGHT_ERROR
= 'More PCX data found than expected';
  PCXIMAGE_TOO_LARGE
= 'PCX image is too large';
 
// added 5/4/2002
  ERROR_UNSUPPORTED
= 'Unsupported PCX format';
 
const
  sPCXImageFile
= 'PCX V3.0+ image';
 
 
// added 19/08/2001
var
  CF_PCX
: WORD;
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                            PCXHeader                              //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
type
  QWORD
= Cardinal; // Seems more logical to me...
 
type
  fColorEntry
= packed record
    ceRed
: BYTE;
    ceGreen
: BYTE;
    ceBlue
: BYTE;
 
end; // of packed record fColorEntry
 
type
 
TPCXImageHeader = packed record
    fID
: BYTE;
    fVersion
: BYTE;
    fCompressed
: BYTE;
    fBitsPerPixel
: BYTE;
    fWindow
: packed record
      wLeft
,
        wTop
,
        wRight
,
        wBottom
: WORD;
   
end; // of packed record fWindow
    fHorzResolution
: WORD;
    fVertResolution
: WORD;
    fColorMap
: array[0..15] of fColorEntry;
    fReserved
: BYTE;
    fPlanes
: BYTE;
    fBytesPerLine
: WORD;
    fPaletteInfo
: WORD;
    fFiller
: array[0..57] of BYTE;
 
end; // of packed record TPCXImageHeader
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                             PCXData                               //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
type
 
TPCXData = object
    fData
: array of BYTE;
 
end; // of Type TPCXData
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                             ScanLine                              //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
const
  fMaxScanLineLength
= $FFF; // Max image width: 4096 pixels
 
type
  mByteArray
= array[0..fMaxScanLineLength] of BYTE;
  pmByteArray
= ^mByteArray;
 
 
// The "standard" pByteArray from Delphi allocates 32768 bytes,
 
// which is a little bit overdone here, I think...
 
const
  fMaxImageWidth
= $FFF; // Max image width: 4096 pixels
 
type
  xByteArray
= array[0..fMaxImageWidth] of BYTE;
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                          PCXPalette                               //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
type
 
TPCXPalette = packed record
    fSignature
: BYTE;
    fPalette
: array[0..255] of fColorEntry;
 
end; // of packed record TPCXPalette
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                             Classes                               //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
type
 
TPCXImage = class;
 
TPCXFile = class;
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                           PCXFile                                 //
 
//                                                                   //
 
//                         File handler                              //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
 
TPCXFile = class(TPersistent)
 
 
private
    fHeight
: Integer;
    fWidth
: Integer;
    fPCXHeader
: TPCXImageHeader;
    fPCXData
: TPCXData;
    fPCXPalette
: TPCXPalette;
    fColorDepth
: QWORD;
    fPixelFormat
: BYTE; // added 5/4/2002
    fCurrentPos
: QWORD;
    fHasPalette
: Boolean; // added 7/5/2002
 
 
protected
   
// Protected declarations
 
 
public
   
// Public declarations
   
constructor Create;
    destructor
Destroy; override;
    procedure
LoadFromFile(const Filename: string);
    procedure
LoadFromStream(Stream: TStream);
    procedure
SaveToFile(const Filename: string);
    procedure
SaveToStream(Stream: TStream);
 
  published
   
// Published declarations
   
// The publishing is done in the TPCXImage section
 
 
end;
 
 
///////////////////////////////////////////////////////////////////////
 
//                                                                   //
 
//                         TPCXImage                                 //
 
//                                                                   //
 
//                       Image handler                               //
 
//                                                                   //
 
///////////////////////////////////////////////////////////////////////
 
 
TPCXImage = class(TGraphic)
 
 
private
   
// Private declarations
    fBitmap
: TBitmap;
    fPCXFile
: TPCXFile;
    fRLine
: xByteArray;
    fGLine
: xByteArray;
    fBLine
: xByteArray;
    fP
: pmByteArray;
    fhPAL
: HPALETTE;
 
    procedure fConvert24BitPCXDataToImage
;
    procedure fConvert1And8BitPCXDataToImage
;
    procedure fConvertImageTo24BitPCXData
;
    procedure fConvertImageTo1And8BitPCXData
(ImageWidthInBytes:
      QWORD
);
    procedure fFillDataLines
(const fLine: array of BYTE);
    procedure fCreatePCXHeader
(const byBitsPerPixel: BYTE;
     
const byPlanes: BYTE; const wBytesPerLine: DWORD);
    procedure fSetPalette
(const wNumColors: WORD);
    procedure fGetPalette
(const wNumColors: WORD);
   
function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
   
function fGetBitmap: TBitmap; // Added 07/05/2002
 
 
protected
   
// Protected declarations
    procedure
Draw(ACanvas: TCanvas; const Rect: TRect); override;
   
function GetHeight: Integer; override;
   
function GetWidth: Integer; override;
    procedure
SetHeight(Value: Integer); override;
    procedure
SetWidth(Value: Integer); override;
   
function GetEmpty: Boolean; override;
 
 
public
   
// Public declarations
   
constructor Create; override;
    destructor
Destroy; override;
    procedure
Assign(Source: TPersistent); override;
    procedure
AssignTo(Dest: TPersistent); override;
    procedure
LoadFromFile(const Filename: string); override;
    procedure
LoadFromStream(Stream: TStream); override;
    procedure
SaveToFile(const Filename: string); override;
    procedure
SaveToStream(Stream: TStream); override;
    procedure
LoadFromClipboardFormat(AFormat: WORD;
     
AData: THandle; APalette: HPALETTE); override;
    procedure
SaveToClipboardFormat(var AFormat: WORD;
     
var AData: THandle; var APalette: HPALETTE); override;
 
  published
   
// Published declarations
    property
Height: Integer
      read
GetHeight write SetHeight;
    property
Width: Integer
      read
GetWidth write SetWidth;
    property
PixelFormat: TPixelFormat
      read fGetPixelFormat
;
    property
Bitmap: TBitmap
      read fGetBitmap
; // Added 7/5/2002
 
 
end;
 
implementation
 
///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                                                                   //
//                         Image handler                             //
//                                                                   //
///////////////////////////////////////////////////////////////////////
 
constructor TPCXImage.Create;
 
begin
  inherited
Create;
 
// Init HPALETTE
  fhPAL
:= 0;
 
 
// Create a private bitmap to hold the image
 
if not Assigned(fBitmap) then
    fBitmap
:= TBitmap.Create;
 
 
// Create the PCXFile
 
if not Assigned(fPCXFile) then
    fPCXFile
:= TPCXFile.Create;
 
end;
//---------------------------------------------------------------------
 
destructor
TPCXImage.Destroy;
 
begin
 
// Reversed order of create
 
// Free fPCXFile
  fPCXFile
.Free;
 
// Free private bitmap
  fBitmap
.Free;
 
// Delete palette
 
if fhPAL <> 0 then
   
DeleteObject(fhPAL);
 
// Distroy all the other things
  inherited
Destroy;
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.SetHeight(Value: Integer);
 
begin
 
if Value >= 0 then
    fBitmap
.Height := Value;
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.SetWidth(Value: Integer);
 
begin
 
if Value >= 0 then
    fBitmap
.Width := Value;
end;
//---------------------------------------------------------------------
 
function TPCXImage.GetHeight: Integer;
 
begin
 
Result := fPCXFile.fHeight;
end;
//---------------------------------------------------------------------
 
function TPCXImage.GetWidth: Integer;
 
begin
 
Result := fPCXFile.fWidth;
end;
//---------------------------------------------------------------------
 
function TPCXImage.fGetBitmap: TBitmap;
 
begin
 
Result := fBitmap;
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// NOT TESTED!
 
procedure
TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
 
ADAta: THandle; APalette: HPALETTE);
 
var
 
Size: QWORD;
 
Buf: Pointer;
 
Stream: TMemoryStream;
  BMP
: TBitmap;
 
begin
 
if (AData = 0) then
   
AData := GetClipBoardData(AFormat);
 
if (AData <> 0) and (AFormat = CF_PCX) then
 
begin
   
Size := GlobalSize(AData);
   
Buf := GlobalLock(AData);
   
try
     
Stream := TMemoryStream.Create;
     
try
       
Stream.SetSize(Size);
       
Move(Buf^, Stream.Memory^, Size);
       
Self.LoadFromStream(Stream);
     
finally
       
Stream.Free;
     
end;
   
finally
 
     
GlobalUnlock(AData);
   
end;
 
end
 
else if (AData <> 0) and (AFormat = CF_BITMAP) then
 
begin
    BMP
:= TBitmap.Create;
   
try
      BMP
.LoadFromClipboardFormat(AFormat, AData, APalette);
     
Self.Assign(BMP);
   
finally
      BMP
.Free;
   
end;
 
end
 
else
   
raise Exception.Create(CLIPBOARD_LOAD_ERROR);
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// NOT TESTED!
 
procedure
TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
 
var AData: THandle; var APalette: HPALETTE);
 
var
 
Stream: TMemoryStream;
 
Data: THandle;
 
Buf: Pointer;
 
begin
 
if Empty then
   
Exit;
 
// First store the bitmap to the clipboard
  fBitmap
.SaveToClipboardFormat(AFormat, AData, APalette);
 
// Then try to save the PCX
 
Stream := TMemoryStream.Create;
 
try
   
SaveToStream(Stream);
   
Stream.Position := 0;
   
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
   
try
     
if Data <> 0 then
     
begin
       
Buf := GlobalLock(Data);
       
try
         
Move(Stream.Memory^, Buf^, Stream.Size);
       
finally
         
GlobalUnlock(Data);
       
end;
       
if SetClipBoardData(CF_PCX, Data) = 0 then
         
raise Exception.Create(CLIPBOARD_SAVE_ERROR);
     
end;
   
except
     
GlobalFree(Data);
     
raise;
   
end;
 
finally
   
Stream.Free;
 
end;
end;
//-------------------------------------------------------------------//
// NOT TESTED!
 
function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002
 
begin
 
if Assigned(fBitmap) then
   
Result := fBitmap.Empty
 
else
   
Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.SaveToFile(const Filename: string);
 
var
  fPCX
: TFileStream;
  W
, WW: QWORD;
 
begin
 
if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
   
raise Exception.Create(BITMAP_EMPTY);
  W
:= fBitmap.Width;
  WW
:= W div 8;
 
if (W mod 8) > 0 then
   
Inc(WW);
 
case fBitmap.PixelFormat of
    pf1bit
:
     
begin
       
// Fully supported by PCX and by this component
        fCreatePCXHeader
(1, 1, WW);
        fConvertImageTo1And8BitPCXData
(WW);
        fGetPalette
(2);
     
end;
    pf4bit
:
     
begin
       
// I don't have 4-bit PCX images to test with
       
// It will be treated as a 24 bit image
        fCreatePCXHeader
(8, 3, W);
        fConvertImageTo24BitPCXData
;
     
end;
    pf8bit
:
     
begin
       
// Fully supported by PCX and by this component
        fCreatePCXHeader
(8, 1, W);
        fConvertImageTo1And8BitPCXData
(W);
        fGetPalette
(256);
     
end;
    pf15bit
:
     
begin
       
// Is this supported in PCX?
       
// It will be treated as a 24 bit image
        fCreatePCXHeader
(8, 3, W);
        fConvertImageTo24BitPCXData
;
     
end;
    pf16bit
:
     
begin
       
// Is this supported in PCX?
       
// It will be treated as a 24 bit image
        fCreatePCXHeader
(8, 3, W);
        fConvertImageTo24BitPCXData
;
     
end;
    pf24bit
:
     
begin
       
// Fully supported by PCX and by this component
        fCreatePCXHeader
(8, 3, W);
        fConvertImageTo24BitPCXData
;
     
end;
    pf32bit
:
     
begin
       
// Not supported by PCX
        fCreatePCXHeader
(8, 3, W);
        fConvertImageTo24BitPCXData
;
     
end;
 
else
   
begin
      fCreatePCXHeader
(8, 3, W);
      fConvertImageTo24BitPCXData
;
   
end; // of else
 
end; // of Case
  fPCX
:= TFileStream.Create(Filename, fmCreate);
 
try
    fPCX
.Position := 0;
   
SaveToStream(fPCX);
 
finally
    fPCX
.Free;
 
end; // of finally
 
SetLength(fPCXFile.fPCXData.fData, 0);
end; // of Procedure SaveToFile
//-------------------------------------------------------------------//
 
procedure
TPCXImage.AssignTo(Dest: TPersistent);
 
var
  bAssignToError
: Boolean;
 
begin
  bAssignToError
:= True;
 
 
if Dest is TBitmap then
 
begin
   
// The old AssignTo procedure was like this.
   
// But then the palette was couldn't be accessed in the calling
   
// program for some reason.
   
// --------------------------
   
// (Dest as TBitmap).Assign(fBitmap);
   
// If fBitmap.Palette <> 0 then
   
//    (Dest as TBitmap).Palette := CopyPalette(fBitmap.Palette);
   
// --------------------------
 
   
// Do the assigning
   
(Dest as TBitmap).Assign(fBitmap);
 
   
if fPCXFile.fHasPalette then
     
(Dest as TBitmap).Palette := CopyPalette(fhPAL);
   
// Now the calling program can access the palette
   
// (if it has one)!
    bAssignToError
:= False;
 
end;
 
 
if Dest is TPicture then
 
begin
   
(Dest as TPicture).Graphic.Assign(fBitmap);
    bAssignToError
:= False;
 
end;
 
 
if bAssignToError then
   
raise Exception.Create(ASSIGNTO_ERROR);
 
 
// You can write other assignments here, if you want...
 
end;
//-------------------------------------------------------------------//
 
procedure
TPCXImage.Assign(Source: TPersistent);
 
var
  iX
, iY: DWORD;
  bAssignError
: Boolean;
 
begin
  bAssignError
:= True;
 
 
if (Source is TBitmap) then
 
begin
    fBitmap
.Assign(Source as TBitmap);
   
if (Source as TBitmap).Palette <> 0 then
   
begin
      fhPAL
:= CopyPalette((Source as TBitmap).Palette);
      fBitmap
.Palette := fhPAL;
   
end;
    bAssignError
:= False;
 
end;
 
 
if (Source is TPicture) then
 
begin
    iX
:= (Source as TPicture).Width;
    iY
:= (Source as TPicture).Height;
    fBitmap
.Width := iX;
    fBitmap
.Height := iY;
    fBitmap
.Canvas.Draw(0, 0, (Source as TPicture).Graphic);
    bAssignError
:= False;
 
end;
 
 
// You can write other assignments here, if you want...
 
 
if bAssignError then
   
raise Exception.Create(ASSIGN_ERROR);
 
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.Draw(ACanvas: TCanvas; const Rect: TRect);
 
begin
 
// Faster
 
// ACanvas.Draw(0,0,fBitmap);
 
 
// Slower
 
ACanvas.StretchDraw(Rect, fBitmap);
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.LoadFromFile(const Filename: string);
 
begin
  fPCXFile
.LoadFromFile(Filename);
 
// added 5/4/2002
 
case fPCXFile.fPixelFormat of
   
1: fConvert1And8BitPCXDataToImage;
   
8: fConvert1And8BitPCXDataToImage;
   
24: fConvert24BitPCXDataToImage;
 
end;
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.SaveToStream(Stream: TStream);
 
begin
  fPCXFile
.SaveToStream(Stream);
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.LoadFromStream(Stream: TStream);
 
begin
  fPCXFile
.LoadFromStream(Stream);
end;
///////////////////////////////////////////////////////////////////////
//                                                                   //
//                       Called by RLE compressor                    //
//                                                                   //
///////////////////////////////////////////////////////////////////////
 
procedure
TPCXImage.fFillDataLines(const fLine: array of BYTE);
 
var
 
By: BYTE;
 
Cnt: WORD;
  I
: QWORD;
  W
: QWORD;
 
begin
  I
:= 0;
 
By := fLine[0];
 
Cnt := $C1;
  W
:= fBitmap.Width;
 
  repeat
 
   
Inc(I);
 
   
if By = fLine[I] then
   
begin
     
Inc(Cnt);
     
if Cnt = $100 then
     
begin
        fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] :=
          BYTE
(Pred(Cnt));
       
Inc(fPCXFile.fCurrentPos);
        fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := By;
       
Inc(fPCXFile.fCurrentPos);
       
Cnt := $C1;
       
By := fLine[I];
     
end;
   
end;
 
   
if (By <> fLine[I]) then
   
begin
     
if (Cnt = $C1) then
     
begin
       
// If (By < $C1) then
       
if (By < $C0) then // changed 5/4/2002
       
begin
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := By;
         
Inc(fPCXFile.fCurrentPos);
       
end
       
else
       
begin
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
         
Inc(fPCXFile.fCurrentPos);
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := By;
         
Inc(fPCXFile.fCurrentPos);
       
end;
     
end
     
else
     
begin
        fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
       
Inc(fPCXFile.fCurrentPos);
        fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := By;
       
Inc(fPCXFile.fCurrentPos);
     
end;
 
     
Cnt := $C1;
     
By := fLine[I];
   
end;
 
 
until I = W - 1;
 
 
// Write the last byte(s)
 
if (Cnt > $C1) then
 
begin
    fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
   
Inc(fPCXFile.fCurrentPos);
 
end;
 
 
if (Cnt = $C1) and (By > $C0) then
 
begin
    fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
   
Inc(fPCXFile.fCurrentPos);
 
end;
 
  fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := By;
 
Inc(fPCXFile.fCurrentPos);
 
end;
//-------------------------------------------------------------------//
//                  RLE Compression algorithm                        //
//-------------------------------------------------------------------//
 
procedure
TPCXImage.fConvertImageTo24BitPCXData; // Renamed 5/4/2002
 
var
  H
, W: QWORD;
  X
, Y: QWORD;
  I
: QWORD;
 
begin
  H
:= fBitmap.Height;
  W
:= fBitmap.Width;
  fPCXFile
.fCurrentPos := 0;
 
SetLength(fPCXFile.fPCXData.fData, 6 * H * W); // To be sure...
  fBitmap
.PixelFormat := pf24bit; // Always do this if you're using
 
// ScanLine!
 
 
for Y := 0 to H - 1 do
 
begin
    fP
:= fBitmap.ScanLine[Y];
    I
:= 0;
   
for X := 0 to W - 1 do
   
begin
      fRLine
[X] := fP[I];
     
Inc(I); // Extract a red line
      fGLine
[X] := fP[I];
     
Inc(I); // Extract a green line
      fBLine
[X] := fP[I];
     
Inc(I); // Extract a blue line
   
end;
 
    fFillDataLines
(fBLine); // Compress the blue line
    fFillDataLines
(fGLine); // Compress the green line
    fFillDataLines
(fRLine); // Compress the red line
 
 
end;
 
 
// Correct the length of fPCXData.fData
 
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
 
procedure
TPCXImage.fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
  QWORD
);
 
var
  H
, W, X, Y: QWORD;
  oldByte
, newByte: BYTE;
 
Cnt: BYTE;
 
begin
  H
:= fBitmap.Height;
  W
:= ImageWidthInBytes;
  fPCXFile
.fCurrentPos := 0;
 
SetLength(fPCXFile.fPCXData.fData, 2 * H * W); // To be sure...
  oldByte
:= 0; // Otherwise the compiler issues a warning about
 
// oldByte not being initialized...
 
Cnt := $C1;
 
for Y := 0 to H - 1 do
 
begin
    fP
:= fBitmap.ScanLine[Y];
   
for X := 0 to W - 1 do
   
begin
 
      newByte
:= fP[X];
 
     
if X > 0 then
     
begin
       
if (Cnt = $FF) then
       
begin
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
         
Inc(fPCXFile.fCurrentPos);
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
         
Inc(fPCXFile.fCurrentPos);
         
Cnt := $C1;
       
end
       
else if newByte = oldByte then
         
Inc(Cnt);
 
       
if newByte <> oldByte then
       
begin
         
if (Cnt > $C1) or (oldByte >= $C0) then
         
begin
            fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
           
Inc(fPCXFile.fCurrentPos);
           
Cnt := $C1;
         
end;
          fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
         
Inc(fPCXFile.fCurrentPos);
       
end;
 
     
end;
      oldByte
:= newByte;
   
end;
   
// Write last byte of line
   
if (Cnt > $C1) or (oldByte >= $C0) then
   
begin
      fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
     
Inc(fPCXFile.fCurrentPos);
     
Cnt := $C1;
   
end;
 
    fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
   
Inc(fPCXFile.fCurrentPos);
 
end;
 
 
// Write last byte of image
 
if (Cnt > $C1) or (oldByte >= $C0) then
 
begin
    fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
   
Inc(fPCXFile.fCurrentPos);
   
// Cnt := 1;
 
end;
  fPCXFile
.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
 
Inc(fPCXFile.fCurrentPos);
 
 
// Correct the length of fPCXData.fData
 
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
//                  RLE Decompression algorithm                      //
//-------------------------------------------------------------------//
 
procedure
TPCXImage.fConvert24BitPCXDataToImage; // Renamed 5/4/2002
 
var
 
  I
: QWORD;
 
By: BYTE;
 
Cnt: BYTE;
  H
, W: QWORD;
  X
, Y: QWORD;
  K
, L: QWORD;
 
begin
  H
:= fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile
.fPCXHeader.fWindow.wTop + 1;
  W
:= fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile
.fPCXHeader.fWindow.wLeft + 1;
  Y
:= 0; // First line of image
  fBitmap
.Width := W; // Set bitmap width
  fBitmap
.Height := H; // Set bitmap height
  fBitmap
.PixelFormat := pf24bit; // Always do this if you're using
 
// ScanLine!
  I
:= 0; // Pointer to data byte of fPXCFile
  repeat
 
   
// Process the red line
   
// ProcessLine(fRLine,W);
 
    X
:= 0; // Pointer to position in Red / Green / Blue line
    repeat
     
By := fPCXFile.fPCXData.fData[I];
     
Inc(I);
 
     
// one byte
     
if By < $C1 then
       
if X <= W then // added 5/4/2002
       
begin
          fRLine
[X] := By;
         
Inc(X);
       
end;
 
     
// multiple bytes (RLE)
     
if By > $C0 then
     
begin
       
Cnt := By and $3F;
 
       
By := fPCXFile.fPCXData.fData[I];
       
Inc(I);
 
       
//FillChar(fRLine[J],Cnt,By);
       
//Inc(J,Cnt);
 
       
for K := 1 to Cnt do
         
if X <= W then // added 5/4/2002
         
begin
            fRLine
[X] := By;
           
Inc(X);
         
end;
 
     
end;
 
   
until X >= W;
 
   
// Process the green line
   
// ProcessLine(fGLine,W);
 
    X
:= 0;
    repeat
     
By := fPCXFile.fPCXData.fData[I];
     
Inc(I);
 
     
// one byte
     
if By < $C1 then
       
if X <= W then // added 5/4/2002
       
begin
          fGLine
[X] := By;
         
Inc(X);
       
end;
 
     
// multiple bytes (RLE)
     
if By > $C0 then
     
begin
       
Cnt := By and $3F;
 
       
By := fPCXFile.fPCXData.fData[I];
       
Inc(I);
 
       
for K := 1 to Cnt do
         
if X <= W then // added 5/4/2002
         
begin
            fGLine
[X] := By;
           
Inc(X);
         
end;
 
     
end;
 
   
until X >= W;
 
   
// Process the blue line
   
// ProcessLine(fBLine,W);
 
    X
:= 0;
    repeat
     
By := fPCXFile.fPCXData.fData[I];
     
Inc(I);
 
     
// one byte
     
if By < $C1 then
       
if X <= W then // added 5/4/2002
       
begin
          fBLine
[X] := By;
         
Inc(X);
       
end;
 
     
// multiple bytes (RLE)
     
if By > $C0 then
     
begin
       
Cnt := By and $3F;
 
       
By := fPCXFile.fPCXData.fData[I];
       
Inc(I);
 
       
for K := 1 to Cnt do
         
if X <= W then // added 5/4/2002
         
begin
            fBLine
[X] := By;
           
Inc(X);
         
end;
 
     
end;
 
   
until X >= W;
 
   
// Write the just processed data RGB lines to the bitmap
    fP
:= fBitmap.ScanLine[Y];
    L
:= 0;
   
for X := 0 to W - 1 do
   
begin
      fP
[L] := fBLine[X];
     
Inc(L);
      fP
[L] := fGLine[X];
     
Inc(L);
      fP
[L] := fRLine[X];
     
Inc(L);
   
end;
 
   
Inc(Y); // Process the next RGB line
 
 
until Y >= H;
 
 
SetLength(fPCXFile.fPCXData.fData, 0);
end;
//-------------------------------------------------------------------//
 
procedure
TPCXImage.fConvert1And8BitPCXDataToImage; // added 5/4/2002
 
var
  I
, J: QWORD;
 
By: BYTE;
 
Cnt: BYTE;
  H
, W, WW: QWORD;
  X
, Y: QWORD;
 
begin
  H
:= fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile
.fPCXHeader.fWindow.wTop + 1;
  W
:= fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile
.fPCXHeader.fWindow.wLeft + 1;
  fBitmap
.Width := W; // Set bitmap width
  fBitmap
.Height := H; // Set bitmap height
  WW
:= W;
 
 
// 1 bit PCX
 
if fPCXFile.fPixelFormat = 1 then
 
begin
   
// All 1 bit images have a palette
    fBitmap
.PixelFormat := pf1bit; // Always do this if you're using
   
// ScanLine!
    WW
:= W div 8; // Correct width for pf1bit
   
if W mod 8 > 0 then
   
begin
     
Inc(WW);
      fBitMap
.Width := WW * 8;
   
end;
    fSetPalette
(2);
 
end;
 
 
// 8 bit PCX
 
if fPCXFile.fPixelFormat = 8 then
 
begin
   
// All 8 bit images have a palette!
   
// This is how to set the palette of a bitmap
   
// 1. First set the bitmap to pf8bit;
   
// 2. then set the palette of the bitmap;
   
// 3. then set the pixels with ScanLine or with Draw.
   
// If you do it with StretchDraw, it won't work. Don't ask me why.
   
// If you don't do it in this order, it won't work either! You'll
   
// get strange colors.
    fBitmap
.PixelFormat := pf8bit; // Always do this if you're using
   
// ScanLine!
    fSetPalette
(256);
 
end;
 
  I
:= 0;
  Y
:= 0;
  repeat
    fP
:= fBitmap.ScanLine[Y];
    X
:= 0; // Pointer to position in line
    repeat
     
By := fPCXFile.fPCXData.fData[I];
     
Inc(I);
 
     
// one byte
     
if By < $C1 then
       
if X <= WW then
       
begin
          fP
[X] := By;
         
Inc(X);
       
end;
 
     
// multiple bytes (RLE)
     
if By > $C0 then
     
begin
       
Cnt := By and $3F;
 
       
By := fPCXFile.fPCXData.fData[I];
       
Inc(I);
 
       
for J := 1 to Cnt do
         
if X <= WW then
         
begin
            fP
[X] := By;
           
Inc(X);
         
end;
 
     
end;
 
   
until X >= WW;
 
   
Inc(Y); // Next line
 
 
until Y >= H;
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.fCreatePCXHeader(const byBitsPerPixel: BYTE;
 
const byPlanes: BYTE; const wBytesPerLine: DWORD);
 
var
  H
, W: WORD;
 
begin
  W
:= fBitmap.Width;
  H
:= fBitmap.Height;
 
 
// PCX header
  fPCXFile
.fPCXHeader.fID := BYTE($0A); // BYTE (1)
  fPCXFile
.fPCXHeader.fVersion := BYTE(5); // BYTE (2)
  fPCXFile
.fPCXHeader.fCompressed := BYTE(1); // BYTE (3)
 
// 0 = uncompressed, 1 = compressed
 
// Only RLE compressed files are supported by this component
  fPCXFile
.fPCXHeader.fBitsPerPixel := BYTE(byBitsPerPixel);
 
// BYTE (4)
  fPCXFile
.fPCXHeader.fWindow.wLeft := WORD(0); // WORD (5,6)
  fPCXFile
.fPCXHeader.fWindow.wTop := WORD(0); // WORD (7,8)
  fPCXFile
.fPCXHeader.fWindow.wRight := WORD(W - 1); // WORD (9,10)
  fPCXFile
.fPCXHeader.fWindow.wBottom := WORD(H - 1); // WORD (11,12)
  fPCXFile
.fPCXHeader.fHorzResolution := WORD(72); // WORD (13,14)
  fPCXFile
.fPCXHeader.fVertResolution := WORD(72); // WORD (15,16)
 
 
FillChar(fPCXFile.fPCXHeader.fColorMap, 48, 0); // Array of Byte
 
// (17..64)
 
  fPCXFile
.fPCXHeader.fReserved := BYTE(0); // BYTE (65)
  fPCXFile
.fPCXHeader.fPlanes := BYTE(byPlanes);
 
// BYTE (66)
  fPCXFile
.fPCXHeader.fBytesPerLine := WORD(wBytesPerLine);
 
// WORD (67,68)
 
// must be even
 
// rounded above
  fPCXFile
.fPCXHeader.fPaletteInfo := WORD(1); // WORD (69,70)
 
 
FillChar(fPCXFile.fPCXHeader.fFiller, 58, 0); // Array of Byte
 
// (71..128)
 
  fPCXFile
.fPixelFormat := fPCXFile.fPCXHeader.fPlanes *
    fPCXFile
.fPCXHeader.fBitsPerPixel;
  fPCXFile
.fColorDepth := 1 shl fPCXFile.fPixelFormat;
end;
//---------------------------------------------------------------------
(*
// From Delphi 5.0, graphics.pas
Function CopyPalette(Palette: HPALETTE): HPALETTE;
 
Var
   
PaletteSize    : Integer;
   
LogPal         : TMaxLogPalette;
 
Begin
Result := 0;
If Palette = 0 then
   
Exit;
PaletteSize := 0;
If GetObject(Palette,SizeOf(PaletteSize),@PaletteSize) = 0 then
   
Exit;
If PaletteSize = 0 then
   
Exit;
With LogPal do
   
Begin
   palVersion
:= $0300;
   palNumEntries
:= PaletteSize;
   
GetPaletteEntries(Palette,0,PaletteSize,palPalEntry);
   
End;
Result := CreatePalette(PLogPalette(@LogPal)^);
End;
*)
//---------------------------------------------------------------------
// From Delphi 5.0, graphics.pas
(*
Procedure TPCXImage.fSetPixelFormat(Value : TPixelFormat);
 
Const
 
BitCounts : Array [pf1Bit..pf32Bit] of BYTE = (1,4,8,16,16,24,32);
 
Var
   DIB    
: TDIBSection;
   
Pal     : HPALETTE;
   DC      
: hDC;
   
KillPal : Boolean;
 
Begin
If Value = GetPixelFormat then
   
Exit;
Case Value of
      pfDevice
: Begin
                 
HandleType := bmDDB;
                 
Exit;
                 
End;
      pfCustom
: InvalidGraphic(@SInvalidPixelFormat);
   
else
     
FillChar(DIB,sizeof(DIB), 0);
 
   DIB
.dsbm := FImage.FDIB.dsbm;
   
KillPal := False;
   
With DIB, dsbm,dsbmih do
     
Begin
      bmBits
:= nil;
      biSize
:= SizeOf(DIB.dsbmih);
      biWidth
:= bmWidth;
      biHeight
:= bmHeight;
      biPlanes
:= 1;
      biBitCount
:= BitCounts[Value];
     
Pal := FImage.FPalette;
     
Case Value of
            pf4Bit  
: Pal := SystemPalette16;
            pf8Bit  
: Begin
                      DC
:= GDICheck(GetDC(0));
                     
Pal := CreateHalftonePalette(DC);
                     
KillPal := True;
                     
ReleaseDC(0, DC);
                     
End;
            pf16Bit
: Begin
                      biCompression
:= BI_BITFIELDS;
                      dsBitFields
[0] := $F800;
                      dsBitFields
[1] := $07E0;
                      dsBitFields
[2] := $001F;
                     
End;
         
End; // of Case
     
Try
     
CopyImage(Handle, Pal, DIB);
     
PaletteModified := (Pal <> 0);
     
Finally
         
if KillPal then
           
DeleteObject(Pal);
           
End; // of Try
     
Changed(Self);
     
End; // of With
   
End; // of Case
End; // of Procedure
*)
//---------------------------------------------------------------------
 
procedure
TPCXImage.fSetPalette(const wNumColors: WORD);
 
(* From Delphi 5.0, graphics.pas
 
Type
   
TPalEntry = packed record
      peRed    
: BYTE;
      peGreen  
: BYTE;
      peBlue    
: BYTE;
     
End;
 
Type
   tagLOGPALETTE
= packed record
      palVersion    
: WORD;
      palNumEntries  
: WORD;
      palPalEntry    
: Array[0..255] of TPalEntry
     
End;
 
Type
   
TMAXLogPalette = tagLOGPALETTE;
   
PMAXLogPalette = ^TMAXLogPalette;
 
Type
   
PRGBQuadArray = ^TRGBQuadArray;
   
TRGBQuadArray = Array[BYTE] of TRGBQuad;
 
Type
   
PRGBQuadArray = ^TRGBQuadArray;
   
TRGBQuadArray = Array[BYTE] of TRGBQuad;
*)
 
var
  pal
: TMaxLogPalette;
  W
: WORD;
 
begin
  pal
.palVersion := $300; // The "Magic" number
  pal
.palNumEntries := wNumColors;
 
for W := 0 to 255 do
 
begin
    pal
.palPalEntry[W].peRed :=
      fPCXFile
.fPCXPalette.fPalette[W].ceRed;
    pal
.palPalEntry[W].peGreen :=
      fPCXFile
.fPCXPalette.fPalette[W].ceGreen;
    pal
.palPalEntry[W].peBlue :=
      fPCXFile
.fPCXPalette.fPalette[W].ceBlue;
    pal
.palPalEntry[W].peFlags := 0;
 
end;
 
 
(* Must we delete the old palette first here? I dont know.
 
If fhPAL <> 0 then
     
DeleteObject(fhPAL);
 
*)
 
  fhPAL
:= CreatePalette(PLogPalette(@pal)^);
 
if fhPAL <> 0 then
    fBitmap
.Palette := fhPAL;
end;
//---------------------------------------------------------------------
 
function TPCXImage.fGetPixelFormat: TPixelFormat;
 
// Only pf1bit, pf4bit and pf8bit images have a palette.
// pf15bit, pf16bit, pf24bit and pf32bit images have no palette.
// You can change the palette of pf1bit images in windows.
// The foreground color and the background color of pf1bit images
// do not have to be black and white. You can choose any tow colors.
// The palette of pf4bit images is fixed.
// The palette entries 0..9 and 240..255 of pf8bit images are reserved
// in windows.
begin
 
Result := pfDevice;
 
case fPCXFile.fPixelFormat of
   
01: Result := pf1bit; // Implemented WITH palette.
   
// 04 : Result :=  pf4bit; // Not yet implemented in this component,
                               
// is however implemented in PCX format.
   
08: Result := pf8bit; // Implemented WITH palette.
   
// 15 : Result := pf15bit; // Not implemented in PCX format?
   
// 16 : Result := pf16bit; // Not implemented in PCX format?
   
24: Result := pf24bit; // Implemented, has no palette.
   
// 32 : Result := pf32bit; // Not implemented in PCX format.
 
end;
end;
//---------------------------------------------------------------------
 
procedure
TPCXImage.fGetPalette(const wNumColors: WORD);
 
var
  pal
: TMaxLogPalette;
  W
: WORD;
 
begin
  fPCXFile
.fPCXPalette.fSignature := $0C;
 
  pal
.palVersion := $300; // The "Magic" number
  pal
.palNumEntries := wNumColors;
 
GetPaletteEntries(CopyPalette(fBitmap.Palette), 0, wNumColors,
    pal
.palPalEntry);
 
for W := 0 to 255 do
   
if W < wNumColors then
   
begin
      fPCXFile
.fPCXPalette.fPalette[W].ceRed :=
        pal
.palPalEntry[W].peRed;
      fPCXFile
.fPCXPalette.fPalette[W].ceGreen :=
        pal
.palPalEntry[W].peGreen;
      fPCXFile
.fPCXPalette.fPalette[W].ceBlue :=
        pal
.palPalEntry[W].peBlue;
   
end
   
else
   
begin
      fPCXFile
.fPCXPalette.fPalette[W].ceRed := 0;
      fPCXFile
.fPCXPalette.fPalette[W].ceGreen := 0;
      fPCXFile
.fPCXPalette.fPalette[W].ceBlue := 0;
   
end;
end;
//=====================================================================
 
///////////////////////////////////////////////////////////////////////
//                                                                   //
//                         TPCXFile                                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////
 
constructor TPCXFile.Create;
 
begin
  inherited
Create;
  fHeight
:= 0;
  fWidth
:= 0;
  fCurrentPos
:= 0;
end;
//---------------------------------------------------------------------
 
destructor
TPCXFile.Destroy;
 
begin
 
SetLength(fPCXData.fData, 0);
  inherited
Destroy;
end;
//---------------------------------------------------------------------
 
procedure
TPCXFile.LoadFromFile(const Filename: string);
 
var
  fPCXStream
: TFileStream;
 
begin
  fPCXStream
:= TFileStream.Create(Filename, fmOpenRead);
 
try
    fPCXStream
.Position := 0;
   
LoadFromStream(fPCXStream);
 
finally
    fPCXStream
.Free;
 
end;
end;
//---------------------------------------------------------------------
 
procedure
TPCXFile.SaveToFile(const Filename: string);
 
var
  fPCXStream
: TFileStream;
 
begin
  fPCXStream
:= TFileStream.Create(Filename, fmCreate);
 
try
    fPCXStream
.Position := 0;
   
SaveToStream(fPCXStream);
 
finally
    fPCXStream
.Free;
 
end;
end;
//---------------------------------------------------------------------
 
procedure
TPCXFile.LoadFromStream(Stream: TStream);
 
var
  fFileLength
: Cardinal;
 
begin
 
// Read the PCX header
 
Stream.Read(fPCXHeader, SizeOf(fPCXHeader));
 
 
// Check the ID byte
 
if fPCXHeader.fID <> $0A then
   
raise Exception.Create(FORMAT_ERROR);
 
 
(*
 
Check PCX version byte
 
======================
 
Versionbyte = 0 => PC PaintBrush V2.5
 
Versionbyte = 2 => PC Paintbrush V2.8 with palette information
 
Versionbyte = 3 => PC Paintbrush V2.8 without palette information
 
Versionbyte = 4 => PC Paintbrush for Windows
 
Versionbyte = 5 => PC Paintbrush V3 and up, and PC Paintbrush Plus
                     
with 24 bit image support
 
*)
 
// Check the PCX version
 
if fPCXHeader.fVersion <> 5 then
   
raise Exception.Create(VERSION_ERROR);
 
 
// Calculate width
  fWidth
:= fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;
 
if fWidth < 0 then
   
raise Exception.Create(WIDTH_OUT_OF_RANGE);
 
 
// Calculate height
  fHeight
:= fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
 
if fHeight < 0 then
   
raise Exception.Create(HEIGHT_OUT_OF_RANGE);
 
 
// Is it too large?
 
if fWidth > fMaxImageWidth then
   
raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);
 
 
// Calculate pixelformat
  fPixelFormat
:= fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel;
 
 
// Calculate number of colors
  fColorDepth
:= 1 shl fPixelFormat;
 
 
// Is this image supported?
 
if not (fPixelFormat in [1, 8, 24]) then
   
raise Exception.Create(ERROR_UNSUPPORTED);
 
 
// The lines following are NOT tested!!!
 
(*
 
If fColorDepth <= 16 then
     
For I := 0 to fColorDepth - 1 do
       
Begin
       
If fPCXHeader.fVersion = 3 then
           
Begin
           fPCXPalette
.fPalette[I].R := fPCXHeader.fColorMap[I].R shl 2;
           fPCXPalette
.fPalette[I].G := fPCXHeader.fColorMap[I].G shl 2;
           fPCXPalette
.fPalette[I].B := fPCXHeader.fColorMap[I].B shl 2;
           
End
       
else
           
Begin
           fPCXPalette
.fPalette[I].R := fPCXHeader.fColorMap[I].R;
           fPCXPalette
.fPalette[I].G := fPCXHeader.fColorMap[I].G;
           fPCXPalette
.fPalette[I].B := fPCXHeader.fColorMap[I].B;
           
End;
       
End;
 
*)
 
 
// Calculate number of data bytes
 
 
// If fFileLength > fMaxDataFileLength then
 
//    Raise Exception.Create(INPUT_FILE_TOO_LARGE);
 
 
if fPixelFormat = 24 then
 
begin
    fFileLength
:= Stream.Size - Stream.Position;
   
SetLength(fPCXData.fData, fFileLength);
   
// Read the data
   
Stream.Read(fPCXData.fData[0], fFileLength);
    fHasPalette
:= False;
 
end;
 
 
if fPixelFormat in [1, 8] then
 
begin
    fFileLength
:= Stream.Size - Stream.Position - 769;
   
SetLength(fPCXData.fData, fFileLength);
   
// Correct number of data bytes
   
Stream.Read(fPCXData.fData[0], fFilelength);
   
// Read the palette
   
Stream.Read(fPCXPalette, SizeOf(fPCXPalette));
    fHasPalette
:= True;
   
// Check palette signature byte
   
if fPCXPalette.fSignature <> $0C then
     
raise Exception.Create(PALETTE_ERROR);
 
end;
 
end;
//---------------------------------------------------------------------
 
procedure
TPCXFile.SaveToStream(Stream: TStream);
 
begin
  fHasPalette
:= False;
 
Stream.Write(fPCXHeader, SizeOf(fPCXHeader));
 
Stream.Write(fPCXData.fData[0], fCurrentPos);
 
if fPixelFormat in [1, 8] then
 
begin
   
Stream.Write(fPCXPalette, SizeOf(fPCXPalette));
    fHasPalette
:= True;
 
end;
end;
//---------------------------------------------------------------------
// Register PCX format
initialization
 
TPicture.RegisterFileFormat('PCX', sPCXImageFile, TPCXImage);
  CF_PCX
:= RegisterClipBoardFormat('PCX Image');
 
TPicture.RegisterClipBoardFormat(CF_PCX, TPCXImage);
 
//---------------------------------------------------------------------
 
// Unregister PCX format
finalization
 
TPicture.UnRegisterGraphicClass(TPCXImage);
 
//---------------------------------------------------------------------
end.

Взято с Delphi Knowledge Base: https://www.baltsoft.com/