PCXImage

Import / export PCX under Delphi (5.0)



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

// //

// TPCXImage //

// ========= //

// //

// Completed: the 10th of August 2001 //

// Author: M. de Haan //

// Email: M.deHaan@inn.nl //

// Tested: under W95 SP1 //

// 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 haning, windows //

// hanging, keyboard locked, and so on //

// Changed: Assign procedure //

// ------------------------------------------------------------------ //

// //

// The PCX image file format is copyrighted by: //

// ZSoft, PC Paintbrush, PC Paintbrush plus //

// Trademarks: NA //

// Royalty fees: NONE //

// //

// The author can not be held responsable for using this software //

// //

// Known issues //

// ------------ //

// 1. Only tested with PCX images version 3.0 (1991) //

// (24 bit images support) //

// //

// 2. No palette support //

// //

// 3. Uncompressed files are not supported //

// //

// 4. AssignTo is NOT tested //

// //

// 5. GetEmpty is NOT tested //

// //

// 6. SaveToClipboardFormat is NOT tested //

// //

// 7. LoadFromClipboardFormat is NOT tested //

// //

// 8. The image will ALWAYS be stored as a 24 bit pcx image //

// //

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



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 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 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 width in PCX data';

   PCX_HEIGHT_ERROR = 'More PCX data found than expected';

   PCXIMAGE_TOO_LARGE = 'PCX image too large';



// added 19/08/2001

Var

   CF_PCX : Word;



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

// //

// PCXHeader //

// //

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



Type

   ColorRecord = packed Record

      R,G,B : Byte;

   End; // of Record



Type

   TPCXImageHeader = packed Record

      fID : Byte;

      fVersion : Byte;

      fCompressed : Byte;

      fBitsPerPixel : Byte;

      fWindow : packed Record

         wLeft,

         wTop,

         wRight,

         wBottom : WORD;

         End; // of Packed Record

      fHorzResolution : WORD;

      fVertResolution : WORD;

      fColorMap : Array[0..15] of ColorRecord;

      fReserved : Byte;

      fPlanes : Byte;

      fBytesPerLine : WORD;

      fPaletteInfo : WORD;

      fFiller : Array[0..57] of Byte;

      End; // of Packed Record



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

// //

// PCXData //

// //

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



// Const

// fMaxDataFileLength = $7FFFFF; // Max filelength 8,3 Mbyte



Type

   TPCXData = Object

      // fData : Array[0..fMaxDataFileLength] of Byte;

      fData : Array of Byte;

   End;



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

// //

// ScanLine //

// //

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



Const

   fMaxScanLineLength = $FFF; // Max image width: 4096 pixels



Type

   mByteArray = Array[0..fMaxScanLineLength] of Byte;

   pmByteArray = ^mByteArray;



// The "standard" pByteArray 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

   fColorEntry = packed Record

      R,G,B : Byte;

   End; // of packed Record



Type

   TPCXPalette = packed Record

      fSignature : Byte;

      fPalette : Array[0..255] of fColorEntry;

   End; // of packed Record



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

// //

// Classes //

// //

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



Type

   TPCXImage = Class;

   TPCXFile = Class;



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

// //

// PCXFile //

// //

// File handler //

// //

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



TPCXFile = Class(TPersistent)



   Private

      fHeight : Integer;

      fWidth : Integer;

      fPCXHeader : TPCXImageHeader;

      fPCXData : TPCXData;

      fPCXPalette : TPCXPalette;

      fColorDepth : Cardinal;

      fCurrentPos : Cardinal;



   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,fGLine,fBLine : xByteArray;

      fP : pmByteArray;



      Procedure ConvertPCXDataToImage;

      Procedure ConvertImageToPCXData;

      Procedure FillDataLines(Const fLine : Array of Byte);

      Procedure CreatePCXHeader;

      // Procedure ProcessLine(Var fLine : Array of Byte; Const W : Cardinal);



   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 }

      // Procedure Draw(ACanvas : TCanvas; Const Rect : TRect); override;

      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;



End;



Implementation



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

// //

// TPCXImage //

// //

// Image handler //

// //

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

constructor TPCXImage.Create;



Begin

inherited Create;



If not Assigned(fBitmap) then

   fBitmap := TBitmap.Create;



If not Assigned(fPCXFile) then

   fPCXFile := TPCXFile.Create;



End;

//----------------------------------------------------------------------

destructor TPCXImage.Destroy;



Begin

fPCXFile.Free;

fBitmap.Free; // Reversed order of create

//SetLength(fRLine,0);

//Setlength(fGLine,0);

//SetLength(fBLine,0);

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;

//--------------------------------------------------------------------//

// The credits for this procedure go to his work of TGIFImage by //

// Reinier P. Sterkenburg //

// NOT TESTED! //

// added 19/08/2001 //

//--------------------------------------------------------------------//

Procedure TPCXImage.LoadFromClipboardFormat(AFormat : Word;

   ADAta : THandle; APalette : HPALETTE);



Var

   Size : Integer;

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

// NOT TESTED! //

// added 19/08/2001 //

//--------------------------------------------------------------------//

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

// added 19/08/2001 //

//--------------------------------------------------------------------//

Function TPCXImage.GetEmpty : Boolean;



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;



Begin

If (fBitmap.Width = 0) or (fBitmap.Height = 0) then

   Raise Exception.Create(BITMAP_EMPTY);

CreatePCXHeader;

ConvertImageToPCXData;

fPCX := TFileStream.Create(Filename,fmCreate);

Try

   fPCX.Position := 0;

   SaveToStream(fPCX);

finally

   fPCX.Free;

   End;

SetLength(fPCXFile.fPCXData.fData,0);

End;

//--------------------------------------------------------------------//

// NOT TESTED! //

//--------------------------------------------------------------------//

Procedure TPCXImage.AssignTo(Dest : TPersistent);



Var

   bAssignToError : Boolean;



Begin

bAssignToError := True;



If Dest is TBitmap then

   Begin

   (Dest as TBitmap).Assign(fBitmap);

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



End;

//--------------------------------------------------------------------//

Procedure TPCXImage.Assign(Source : TPersistent);



Var

   iX,iY : Integer;

   bAssignError : Boolean;



Begin

bAssignError := True;



If (Source is TBitmap) then

   Begin

   fBitmap.Assign(Source as TBitmap);


   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 bAssignError then

   Raise Exception.Create(ASSIGN_ERROR);



End;

//----------------------------------------------------------------------

Procedure TPCXImage.Draw(ACanvas : TCanvas; const Rect : TRect);



Begin

// ACanvas.Draw(0,0,fBitmap); // faster

ACanvas.StretchDraw(Rect,fBitmap); // slower

End;

//----------------------------------------------------------------------

Procedure TPCXImage.LoadFromFile(const Filename : String);



Begin

fPCXFile.LoadFromFile(Filename);

ConvertPCXDataToImage;

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.FillDataLines(Const fLine : Array of Byte);



Var

   By : Byte;

   Cnt : WORD;

   I : Cardinal;

   W : Cardinal;



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

            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);



// If fPCXFile.fCurrentPos > fMaxDataFileLength then

// Raise Exception.Create(PCXIMAGE_TOO_LARGE);



End;

//--------------------------------------------------------------------//

// RLE Compression algorithm //

//--------------------------------------------------------------------//

Procedure TPCXImage.ConvertImageToPCXData;



Var

   H,W : Cardinal;

   X,Y : Cardinal;

   I : Cardinal;



Begin

H := fBitmap.Height;

W := fBitmap.Width;

fPCXFile.fCurrentPos := 0;

SetLength(fPCXFile.fPCXData.fData,6 * H * W); // to be sure

// SetLength(fRLine,W);

// SetLength(fGLine,W);

// SetLength(fBLine,W);

fBitmap.PixelFormat := pf24bit; // 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;



   FillDataLines(fBLine); // Compress the blue line

   FillDataLines(fGLine); // Compress the green line

   FillDataLines(fRLine); // Compress the red line



   End;







// Correct the length of fPCXData.fData

SetLength(fPCXFile.fPCXData.fData,fPCXFile.fCurrentPos);

End;

//----------------------------------------------------------------------

(*

Procedure TPCXImage.ProcessLine(Var fLine : Array of Byte; Const W : Cardinal);



Var

   Cnt : Integer;

   J,K : Cardinal;

   By : Byte;



Begin

J := 0;

Repeat

   By := fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos];

   Inc(fPCXFile.fCurrentPos);



   // one byte

   If By < $C1 then

      Begin

      fLine[J] := By;

      Inc(J);

      End;



   // multiple bytes (RLE)

   If By > $C0 then

      Begin

      Cnt := By - $C0;



      By := fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos];

      Inc(fPCXFile.fCurrentPos);



      For K := 1 to Cnt do

         Begin

         fLine[J] := By;

         Inc(J);

         End;



      End;



Until J >= W;

End;

*)

//--------------------------------------------------------------------//

// RLE Decompression algorithm //

//--------------------------------------------------------------------//

Procedure TPCXImage.ConvertPCXDataToImage;



Var



   I,J : Cardinal;

   By : Byte;

   Cnt : Byte;

   H,W : Cardinal;

   Y : Cardinal;

   K,L : Cardinal;



Begin

H := fPCXFile.fPCXHeader.fWindow.wBottom - fPCXFile.fPCXHeader.fWindow.wTop + 1;

W := fPCXFile.fPCXHeader.fWindow.wRight - fPCXFile.fPCXHeader.fWindow.wLeft + 1;

//SetLength(fRLine,W); // Adjust line length

//SetLength(fGLine,W); // Adjust line length

//SetLength(fBLine,W); // Adjust line length

Y := 0; // First line of image

fBitmap.Width := W; // Set bitmap width

fBitmap.Height := H; // Set bitmap height

fBitmap.PixelFormat := pf24bit; // Do this if you're using ScanLine!

I := 0; // Pointer to data byte of fPXCFile

Repeat



   // Process the red line

   // ProcessLine(fRLine,W);



   J := 0; // Pointer to position in Red / Green / Blue line

   Repeat

      By := fPCXFile.fPCXData.fData[I];

      Inc(I);



      // one byte

      If By < $C1 then

         Begin

         fRLine[J] := By;

         Inc(J);

         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

            Begin

            fRLine[J] := By;

            Inc(J);

            End;



         End;



   Until J >= W;



   If J > W then

      Raise Exception.Create(PCX_WIDTH_ERROR);



   // Process the green line

   // ProcessLine(fGLine,W);



   J := 0;

   Repeat

      By := fPCXFile.fPCXData.fData[I];

      Inc(I);



      // one byte

      If By < $C1 then

         Begin

         fGLine[J] := By;

         Inc(J);

         End;



      // multiple bytes (RLE)

      If By > $C0 then

         Begin

         Cnt := By and $3F;



         By := fPCXFile.fPCXData.fData[I];

         Inc(I);



         //FillChar(fGLine[J],Cnt,By);

         //Inc(J,Cnt);



         For K := 1 to Cnt do

            Begin

            fGLine[J] := By;

            Inc(J);

            End;



         End;



   Until J >= W;



   If J > W then

      Raise Exception.Create(PCX_WIDTH_ERROR);



   // Process the blue line

   // ProcessLine(fBLine,W);



   J := 0;

   Repeat

      By := fPCXFile.fPCXData.fData[I];

      Inc(I);



      // one byte

      If By < $C1 then

         Begin

         fBLine[J] := By;

         Inc(J);

         End;



      // multiple bytes (RLE)

      If By > $C0 then

         Begin

         Cnt := By and $3F;



         By := fPCXFile.fPCXData.fData[I];

         Inc(I);



         //FillChar(fBLine[J],Cnt,By);

         //Inc(J,Cnt);



         For K := 1 to Cnt do

            Begin

            fBLine[J] := By;

            Inc(J);

            End;



         End;



   Until J >= W;



   If J > W then

      Raise Exception.Create(PCX_WIDTH_ERROR);



   // Write the just processed data RGB lines to the bitmap

   fP := fBitmap.ScanLine[Y];

   L := 0;

   For K := 0 to W - 1 do

      Begin

      fP[L] := fBLine[K]; Inc(L);

      fP[L] := fGLine[K]; Inc(L);

      fP[L] := fRLine[K]; Inc(L);

      End;



   Inc(Y); // Process the next RGB line



   // If I > fMaxDataFileLength then

   // Raise Exception.Create(PCXIMAGE_TOO_LARGE);



Until Y >= H;



If Y > H then

      Raise Exception.Create(PCX_HEIGHT_ERROR);



// No need for those any more

SetLength(fPCXFile.fPCXData.fData,0);

// SetLength(fRLine,0);

// SetLength(fGLine,0);

// SetLength(fBLine,0);

End;

//----------------------------------------------------------------------

Procedure TPCXImage.CreatePCXHeader;



Var

   H,W,W1 : WORD;



Begin

W := fBitmap.Width;

H := fBitmap.Height;



// PCX header

fPCXFile.fPCXHeader.fID := $0A; // BYTE

fPCXFile.fPCXHeader.fVersion := 5; // BYTE

fPCXFile.fPCXHeader.fCompressed := 1; // BYTE

                                                     // 1 = compressed

                                                     // 0 = uncompressed

fPCXFile.fPCXHeader.fBitsPerPixel := 8; // BYTE

fPCXFile.fPCXHeader.fWindow.wLeft := 0; // WORD

fPCXFile.fPCXHeader.fWindow.wTop := 0; // WORD

fPCXFile.fPCXHeader.fWindow.wRight := W - 1; // WORD

fPCXFile.fPCXHeader.fWindow.wBottom := H - 1; // WORD

fPCXFile.fPCXHeader.fHorzResolution := 72; // WORD

fPCXFile.fPCXHeader.fVertResolution := 72; // WORD



FillChar(fPCXFile.fPCXHeader.fColorMap,48,0); // Array of Byte



W1 := W;

If W and 1 = 1 then // is odd

   Inc(W1); // then add 1,

                    // must be even and rounded up above



fPCXFile.fPCXHeader.fReserved := 0; // BYTE

fPCXFile.fPCXHeader.fPlanes := 3; // BYTE

fPCXFile.fPCXHeader.fBytesPerLine := W1; // WORD

                                                     // must be even

                                                     // rounded above

fPCXFile.fPCXHeader.fPaletteInfo := 1; // WORD



FillChar(fPCXFile.fPCXHeader.fFiller,58,0); // Array of Byte



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;

   I : Integer;



Begin

// Read PCX header

Stream.Read(fPCXHeader,SizeOf(fPCXHeader));



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

// 24 bit image support

If fPCXHeader.fVersion <> 5 then

   Raise Exception.Create(VERSION_ERROR);



fWidth := fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;

If fWidth < 0 then

   Raise Exception.Create(WIDTH_OUT_OF_RANGE);



fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;

If fHeight < 0 then

   Raise Exception.Create(HEIGHT_OUT_OF_RANGE);



If fWidth > fMaxImageWidth then

   Raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);



fColorDepth := 1 shl (fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel);



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



fFileLength := Stream.Size - Stream.Position;

SetLength(fPCXData.fData,fFileLength);



// If fFileLength > fMaxDataFileLength then

// Raise Exception.Create(INPUT_FILE_TOO_LARGE);



Stream.Read(fPCXData.fData[0],fFileLength);



{

If fColorDepth = 256 then

   Begin

   Stream.Read(fPCXPalette,SizeOf(fPCXPalette));

   If fPCXPalette.fSignature <> $0C then

      Raise Exception.Create(PALETTE_ERROR);

   End;

}



End;

//----------------------------------------------------------------------

Procedure TPCXFile.SaveToStream(Stream : TStream);



Begin

Stream.Write(fPCXHeader,SizeOf(fPCXHeader));

Stream.Write(fPCXData.fData[0],fCurrentPos);

End;

//----------------------------------------------------------------------

Initialization

   TPicture.RegisterFileFormat('PCX','PC PaintBrush bitmap',TPCXImage);



//----------------------------------------------------------------------

Finalization

   TPicture.UnRegisterGraphicClass(TPCXImage);



//----------------------------------------------------------------------

End.

//======================================================================




 

Share this article!

Follow us!

Find more helpful articles: