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

Previous  Top  Next

    
 

 

 

 

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

Code:

///////////////////////////////////////////////////////////////////////

//                                                                   //

//                           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.

©Drkb::04303

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