Das PCX-Format wurde im Jahr 1982 von der Firma ZSoft entwickelt und in den eigenen Produkten Paintbrush und FRIEZE (Residentes Hilfsprogramm zum Import von Bildern aus anderen Anwendungen z. B. Lotus 1-2-3) eingesetzt. Heute wird das Format von den meisten Grafikprogrammen kaum mehr unterstützt.
Zum Zeitpunkt der Entwicklung von PCX gab es lediglich Hercules- und CGA-Grafikadapter. Mit den Jahren wurden die Grafikkarten besser und neue Grafikmodi entstanden (EGA, MCGA, VGA). Diese wurden dann durch neuere Versionen des PCX-Formates abgedeckt. Die Änderungen der Formatdefinition beschränkten sich aber im Wesentlichen auf die Farbpalette.
Deshalb ist es sehr aufwendig, ein PCX Bild in ein heutiges gängiges Bitmap-Format zu konvertieren, aber es ist natürlich möglich.
Unit pcx.pasUnit PCX;
interface
{Unit PCX.pas}
uses vga_code;
TYPE
TPalette = array[0..767] of Byte;
PalettePtr = ^TPalette;
VAR
Pal: PalettePtr; { PCX palette }
PROCEDURE Show_PCX(Filename: String; Out: boolean);
IMPLEMENTATION
TYPE
{ PCX stuff }
PCXHeaderPtr= ^PCXHeader;
PCXHeader = record
Signature : Char;
Version : Char;
Encoding : Char;
BitsPerPixel : Char;
XMin,YMin,
XMax,YMax : Integer;
HRes,VRes : Integer;
Palette : Array [0..47] of byte;
Reserved : Char;
Planes : Char;
BytesPerLine : Integer;
PaletteType : Integer;
Filler : Array [0..57] of byte;
end;
Procedure ExtractLineASM (BytesWide:Integer;Var Source,Dest:Pointer);
var
DestSeg,
DestOfs,
SourceSeg,
SourceOfs : Word;
begin
SourceSeg := Seg (Source^);
SourceOfs := Ofs (Source^);
DestSeg := Seg (Dest^);
DestOfs := Ofs (Dest^);
asm
push ds
push si
cld
mov ax,DestSeg
mov es,ax
mov di,DestOfs { es:di -> destination pointer }
mov ax,SourceSeg
mov ds,ax
mov si,SourceOfs { ds:si -> source buffer }
mov bx,di
add bx,BytesWide { bx holds position to stop for this row }
xor cx,cx
@@GetNextByte:
cmp bx,di { are we done with the line }
jbe @@ExitHere
lodsb { al contains next byte }
mov ah,al
and ah,0C0h
cmp ah,0C0h
jne @@SingleByte
{ must be a run of bytes }
mov cl,al
and cl,3Fh
lodsb
rep stosb
jmp @@GetNextByte
@@SingleByte:
stosb
jmp @@GetNextByte
@@ExitHere:
mov SourceSeg,ds
mov SourceOfs,si
mov DestSeg,es
mov DestOfs,di
pop si
pop ds
end;
Source := Ptr (SourceSeg,SourceOfs);
Dest := Ptr (DestSeg,DestOfs);
end;
Procedure DisplayPCX (X,Y:Integer;Buf:Pointer);
var
I,NumRows,
BytesWide : Integer;
Header : PCXHeaderPtr;
DestPtr : Pointer;
Offset : Word;
begin
Header := Ptr (Seg(Buf^),Ofs(Buf^));
Buf := Ptr (Seg(Buf^),Ofs(Buf^)+128);
Offset := Y * 320 + X;
NumRows := Header^.YMax - Header^.YMin + 1;
BytesWide := Header^.XMax - Header^.XMin + 1;
If Odd (BytesWide) then Inc (BytesWide);
For I := 1 to NumRows do begin
DestPtr := Ptr ($A000,Offset);
ExtractLineASM (BytesWide,Buf,DestPtr);
Inc (Offset,320);
end;
end;
{ end PCX stuff }
VAR
Hdr: PCXHeaderPtr; { PCX header structure & file }
F: File; { PCX file }
Shade, Size: Word; { RGB shade, file size }
PROCEDURE Show_PCX(Filename: String; Out: boolean);
Begin
Assign(F, filename); { open PCX file }
Reset(F,1);
Size := FileSize(F);
GetMem(Hdr, Size); { load PCX into memory }
Blockread(F, Hdr^, Size);
Close(F);
Pal := Ptr( Seg(Hdr^), Ofs(Hdr^) + Size - 768); { get palette location }
Port[968] := 0; { set palette }
FOR Shade := 0 TO 767 DO
Port[969] := Pal^[Shade] SHR 2;
if Out = true then begin
GrabPallette;
BlackOut;
end;
DisplayPCX(0, 0, Hdr); { decode PCX to screen }
FreeMem(Hdr, Size);
End;
BEGIN
END.
to set mode 13h, use this procedure
procedure SetMcga;
begin
asm
mov ax,0013h
int 10h
end;
end;
and to set to text mode
procedure SetText;
begin
asm
mov ax,0003h
int 10h
end;
end;
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 dont 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 couldnt 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 youre 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 youre 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 youre 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 dont do it in this order, it won't work either! You'll
// get strange colors.
fBitmap.PixelFormat := pf8bit; // Always do this if youre 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.
//=====================================================================
uses PCXImage
Procedure SW(const bmp: TBitmap);
var
color,grayScale : longint;
r,g,b : byte;
h,w : integer;
begin
bmp.PixelFormat := pf24bit; //bitmap muss mind. 24Bit sein, sonst gehts nicht
for h := 0 to bmp.height do
begin
for w := 0 to bmp.width do
begin
color:=colortorgb(bmp.Canvas.pixels[w,h]);
if color = clBlack then
color := clWhite
else
color := clBlack;
bmp.canvas.Pixels[w,h] := color;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
end;
procedure TForm1.Button3Click(Sender: TObject);
var
tmpInt: Integer;
pcx : TPCXImage;
begin
pcx := TPCXImage.Create;
pcx.Assign(Image2.Picture.Graphic);
if SaveDialog1.Execute then pcx.SaveToFile(SaveDialog1.FileName + '.pcx');
end;
procedure TForm1.Button4Click(Sender: TObject);
var
Picture: TPicture;
Bitmap: TBitmap;
begin
Picture := TPicture.Create;
try
if SaveDialog1.Execute then
Picture.LoadFromFile('sample_640×426.pcx');
//Picture.Assign(Image1.Picture);
Bitmap := TBitmap.Create;
try
Bitmap.Width := Picture.Width;
Bitmap.Height := Picture.Height;
Bitmap.Canvas.Draw(0, 0, Picture.Graphic);
Bitmap.SaveToFile(SaveDialog1.FileName + '.bmp');
finally
Bitmap.Free;
end;
finally
Picture.Free;
end;
end;
Keine Kommentare:
Kommentar veröffentlichen