Graphic Delphi

  1. Home
  2. Delphi
  3. Graphic
  4. PCXImage
Title: PCXImage
Question: How to write a graphic component?
Answer:
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// ========= //
// //
// Completed: The 10th of August 2001 //
// Author: M. de Haan //
// Email: M.deHaan@inn.nl //
// Tested: under W95 SP1, NT4 SP6 //
// 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. //
// //
///////////////////////////////////////////////////////////////////////
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);
// --------------------------
// 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 If (By 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 If X 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 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 If X 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 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 If X 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 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 If X 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 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 don't 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 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 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 Raise Exception.Create(WIDTH_OUT_OF_RANGE);
// Calculate height
fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
If fHeight 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 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.
//=====================================================================