Эксперт
Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва
Репутация: 80
Всего: 162
|
Fully supports reading and writing of: 1, 8 and 24 bit PCX images. | Код |
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// ========= //
// //
// Completed: The 10th of August 2001 //
// Author: M. de Haan //
// Email: [email protected] //
// Tested: under W95 SP1, NT4 SP6, WIN2000 //
// Version: 1.0 //
//-------------------------------------------------------------------//
// Update: The 14th of August 2001 to version 1.1. //
// Reason: Added version check. //
// Added comment info on version. //
// Changed PCX header ID check. //
//-------------------------------------------------------------------//
// Update: The 19th of August 2001 to version 2.0. //
// Reason: Warning from Delphi about using abstract methods, //
// caused by not implementing ALL TGraphic methods. //
// (Thanks goes to R.P. Sterkenburg for his diagnostic.) //
// Added: SaveToClipboardFormat, LoadFromClipboardFormat, //
// GetEmpty. //
//-------------------------------------------------------------------//
// Update: The 13th of October 2001 to version 2.1. //
// Reason: strange errors, read errors, EExternalException, IDE //
// hanging, Delphi hanging, Debugger hanging, windows //
// hanging, keyboard locked, and so on. //
// Changed: Assign procedure. //
//-------------------------------------------------------------------//
// Update: The 5th of April 2002 to version 2.2. //
// Changed: RLE compressor routine. //
// Reason: Incompatibility problems with other programs caused //
// by the RLE compressor. //
// Other programs encode: $C0 as: $C1 $C0. //
// ($C0 means: repeat the following byte 0 times //
// $C1 means: repeat the following byte 1 time.) //
// Changed: File read routine. //
// Reason: Now detects unsupported PCX data formats. //
// Added: 'Unsupported data format' in exception handler. //
// Added: 1 bit PCX support in reading. //
// Added: Procedure Convert1BitPCXDataToImage. //
// Renamed: Procedure ConvertPCXDataToImage to //
// Convert24BitPCXDataToImage. //
//-------------------------------------------------------------------//
// Update: The 14th of April 2002 to version 2.3. //
// Now capable of reading and writing 1 and 24 bit PCX //
// images. //
// Added: 1 bit PCX support in writing. //
// Added: Procedure ConvertImageTo1bitPCXData. //
// Changed: Procedure CreatePCXHeader. //
// Changed: Procedure TPCXImage.SaveToFile. //
//-------------------------------------------------------------------//
// Update: The 19th of April 2002 to version 2.4. //
// Now capable of reading and writing: 1, 8 and 24 bit //
// PCX images. //
// Added: 8 bit PCX support in reading and writing. //
// Renamed: Procedure ConvertImageTo1And8bitPCXData. //
// Renamed: Procedure Convert1And8bitPCXDataToImage. //
// Changed: Procedure fSetPalette, fGetPalette. //
//-------------------------------------------------------------------//
// Update: The 7th of May 2002 to version 2.5. //
// Reason: The palette of 8-bit PCX images couldn't be read in //
// the calling program. //
// Changed: Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
// Tested: All formats were tested with the following programs: //
// - import in Word 97, //
// * (Word ignores the palette of 1 bit PCX images!) //
// - import and export in MigroGrafX. //
// * (MicroGrafX also ignores the palette of 1 bit PCX //
// images.) //
// No problems were detected. //
// //
//===================================================================//
// //
// The PCX image file format is copyrighted by: //
// ZSoft, PC Paintbrush, PC Paintbrush plus //
// Trademarks: N/A //
// Royalty fees: NONE //
// //
//===================================================================//
// //
// The author can not be held responsable for using this software //
// in anyway. //
// //
// The features and restrictions of this component are: //
// ---------------------------------------------------- //
// //
// The reading and writing (import / export) of files / images: //
// - PCX version 5 definition, PC Paintbrush 3 and higher, //
// - RLE-compressed, //
// - 1 and 8 bit PCX images WITH palette and //
// - 24 bit PCX images without palette, //
// are supported by this component. //
// //
// Known issues //
// ------------ //
// //
// 1) GetEmpty is NOT tested. //
// //
// 2) SaveToClipboardFormat is NOT tested. //
// //
// 3) LoadFromClipboardFormat is NOT tested. //
// //
// 4) 4 bit PCX images (with palette) are NOT (yet) implemented. //
// (I have no 4-bit PCX images to test it on...) //
// //
///////////////////////////////////////////////////////////////////////
unit
PCXImage;
interface
uses
Windows,
SysUtils,
Classes,
Graphics;
const
WIDTH_OUT_OF_RANGE = 'Illegal width entry in PCX file header';
HEIGHT_OUT_OF_RANGE = 'Illegal height entry in PCX file header';
FILE_FORMAT_ERROR = 'Invalid file format';
VERSION_ERROR = 'Only PC Paintbrush (plus) V3.0 and ' +
'higher are supported';
FORMAT_ERROR = 'Illegal identification byte in PCX file' +
' header';
PALETTE_ERROR = 'Invalid palette signature found';
ASSIGN_ERROR = 'Can only Assign a TBitmap or a TPicture';
ASSIGNTO_ERROR = 'Can only AssignTo a TBitmap';
PCXIMAGE_EMPTY = 'The PCX image is empty';
BITMAP_EMPTY = 'The bitmap is empty';
INPUT_FILE_TOO_LARGE = 'The input file is too large to be read';
IMAGE_WIDTH_TOO_LARGE = 'Width of PCX image is too large to handle';
// added 19/08/2001
CLIPBOARD_LOAD_ERROR = 'Loading from clipboard failed';
// added 19/08/2001
CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
// added 14/10/2001
PCX_WIDTH_ERROR = 'Unexpected line length in PCX data';
PCX_HEIGHT_ERROR = 'More PCX data found than expected';
PCXIMAGE_TOO_LARGE = 'PCX image is too large';
// added 5/4/2002
ERROR_UNSUPPORTED = 'Unsupported PCX format';
const
sPCXImageFile = 'PCX V3.0+ image';
// added 19/08/2001
var
CF_PCX: WORD;
///////////////////////////////////////////////////////////////////////
// //
// PCXHeader //
// //
///////////////////////////////////////////////////////////////////////
type
QWORD = Cardinal; // Seems more logical to me...
type
fColorEntry = packed record
ceRed: BYTE;
ceGreen: BYTE;
ceBlue: BYTE;
end; // of packed record fColorEntry
type
TPCXImageHeader = packed record
fID: BYTE;
fVersion: BYTE;
fCompressed: BYTE;
fBitsPerPixel: BYTE;
fWindow: packed record
wLeft,
wTop,
wRight,
wBottom: WORD;
end; // of packed record fWindow
fHorzResolution: WORD;
fVertResolution: WORD;
fColorMap: array[0..15] of fColorEntry;
fReserved: BYTE;
fPlanes: BYTE;
fBytesPerLine: WORD;
fPaletteInfo: WORD;
fFiller: array[0..57] of BYTE;
end; // of packed record TPCXImageHeader
///////////////////////////////////////////////////////////////////////
// //
// PCXData //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXData = object
fData: array of BYTE;
end; // of Type TPCXData
///////////////////////////////////////////////////////////////////////
// //
// ScanLine //
// //
///////////////////////////////////////////////////////////////////////
const
fMaxScanLineLength = $FFF; // Max image width: 4096 pixels
type
mByteArray = array[0..fMaxScanLineLength] of BYTE;
pmByteArray = ^mByteArray;
// The "standard" pByteArray from Delphi allocates 32768 bytes,
// which is a little bit overdone here, I think...
const
fMaxImageWidth = $FFF; // Max image width: 4096 pixels
type
xByteArray = array[0..fMaxImageWidth] of BYTE;
///////////////////////////////////////////////////////////////////////
// //
// PCXPalette //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXPalette = packed record
fSignature: BYTE;
fPalette: array[0..255] of fColorEntry;
end; // of packed record TPCXPalette
///////////////////////////////////////////////////////////////////////
// //
// Classes //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXImage = class;
TPCXFile = class;
///////////////////////////////////////////////////////////////////////
// //
// PCXFile //
// //
// File handler //
// //
///////////////////////////////////////////////////////////////////////
TPCXFile = class(TPersistent)
private
fHeight: Integer;
fWidth: Integer;
fPCXHeader: TPCXImageHeader;
fPCXData: TPCXData;
fPCXPalette: TPCXPalette;
fColorDepth: QWORD;
fPixelFormat: BYTE; // added 5/4/2002
fCurrentPos: QWORD;
fHasPalette: Boolean; // added 7/5/2002
protected
// Protected declarations
public
// Public declarations
constructor Create;
destructor Destroy; override;
procedure LoadFromFile(const Filename: string);
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(const Filename: string);
procedure SaveToStream(Stream: TStream);
published
// Published declarations
// The publishing is done in the TPCXImage section
end;
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// Image handler //
// //
///////////////////////////////////////////////////////////////////////
TPCXImage = class(TGraphic)
private
// Private declarations
fBitmap: TBitmap;
fPCXFile: TPCXFile;
fRLine: xByteArray;
fGLine: xByteArray;
fBLine: xByteArray;
fP: pmByteArray;
fhPAL: HPALETTE;
procedure fConvert24BitPCXDataToImage;
procedure fConvert1And8BitPCXDataToImage;
procedure fConvertImageTo24BitPCXData;
procedure fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
QWORD);
procedure fFillDataLines(const fLine: array of BYTE);
procedure fCreatePCXHeader(const byBitsPerPixel: BYTE;
const byPlanes: BYTE; const wBytesPerLine: DWORD);
procedure fSetPalette(const wNumColors: WORD);
procedure fGetPalette(const wNumColors: WORD);
function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
function fGetBitmap: TBitmap; // Added 07/05/2002
protected
// Protected declarations
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure SetHeight(Value: Integer); override;
procedure SetWidth(Value: Integer); override;
function GetEmpty: Boolean; override;
public
// Public declarations
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
procedure LoadFromFile(const Filename: string); override;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToFile(const Filename: string); override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromClipboardFormat(AFormat: WORD;
AData: THandle; APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE); override;
published
// Published declarations
property Height: Integer
read GetHeight write SetHeight;
property Width: Integer
read GetWidth write SetWidth;
property PixelFormat: TPixelFormat
read fGetPixelFormat;
property Bitmap: TBitmap
read fGetBitmap; // Added 7/5/2002
end;
implementation
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// Image handler //
// //
///////////////////////////////////////////////////////////////////////
constructor TPCXImage.Create;
begin
inherited Create;
// Init HPALETTE
fhPAL := 0;
// Create a private bitmap to hold the image
if not Assigned(fBitmap) then
fBitmap := TBitmap.Create;
// Create the PCXFile
if not Assigned(fPCXFile) then
fPCXFile := TPCXFile.Create;
end;
//---------------------------------------------------------------------
destructor TPCXImage.Destroy;
begin
// Reversed order of create
// Free fPCXFile
fPCXFile.Free;
// Free private bitmap
fBitmap.Free;
// Delete palette
if fhPAL <> 0 then
DeleteObject(fhPAL);
// Distroy all the other things
inherited Destroy;
end;
//---------------------------------------------------------------------
procedure TPCXImage.SetHeight(Value: Integer);
begin
if Value >= 0 then
fBitmap.Height := Value;
end;
//---------------------------------------------------------------------
procedure TPCXImage.SetWidth(Value: Integer);
begin
if Value >= 0 then
fBitmap.Width := Value;
end;
//---------------------------------------------------------------------
function TPCXImage.GetHeight: Integer;
begin
Result := fPCXFile.fHeight;
end;
//---------------------------------------------------------------------
function TPCXImage.GetWidth: Integer;
begin
Result := fPCXFile.fWidth;
end;
//---------------------------------------------------------------------
function TPCXImage.fGetBitmap: TBitmap;
begin
Result := fBitmap;
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by //
// Reinier P. Sterkenburg //
// Added 19/08/2001 //
//-------------------------------------------------------------------//
// NOT TESTED!
procedure TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
ADAta: THandle; APalette: HPALETTE);
var
Size: QWORD;
Buf: Pointer;
Stream: TMemoryStream;
BMP: TBitmap;
begin
if (AData = 0) then
AData := GetClipBoardData(AFormat);
if (AData <> 0) and (AFormat = CF_PCX) then
begin
Size := GlobalSize(AData);
Buf := GlobalLock(AData);
try
Stream := TMemoryStream.Create;
try
Stream.SetSize(Size);
Move(Buf^, Stream.Memory^, Size);
Self.LoadFromStream(Stream);
finally
Stream.Free;
end;
finally
GlobalUnlock(AData);
end;
end
else if (AData <> 0) and (AFormat = CF_BITMAP) then
begin
BMP := TBitmap.Create;
try
BMP.LoadFromClipboardFormat(AFormat, AData, APalette);
Self.Assign(BMP);
finally
BMP.Free;
end;
end
else
raise Exception.Create(CLIPBOARD_LOAD_ERROR);
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by //
// Reinier P. Sterkenburg //
// Added 19/08/2001 //
//-------------------------------------------------------------------//
// NOT TESTED!
procedure TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE);
var
Stream: TMemoryStream;
Data: THandle;
Buf: Pointer;
begin
if Empty then
Exit;
// First store the bitmap to the clipboard
fBitmap.SaveToClipboardFormat(AFormat, AData, APalette);
// Then try to save the PCX
Stream := TMemoryStream.Create;
try
SaveToStream(Stream);
Stream.Position := 0;
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
try
if Data <> 0 then
begin
Buf := GlobalLock(Data);
try
Move(Stream.Memory^, Buf^, Stream.Size);
finally
GlobalUnlock(Data);
end;
if SetClipBoardData(CF_PCX, Data) = 0 then
raise Exception.Create(CLIPBOARD_SAVE_ERROR);
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
end;
//-------------------------------------------------------------------//
// NOT TESTED!
function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002
begin
if Assigned(fBitmap) then
Result := fBitmap.Empty
else
Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
end;
//---------------------------------------------------------------------
procedure TPCXImage.SaveToFile(const Filename: string);
var
fPCX: TFileStream;
W, WW: QWORD;
begin
if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
raise Exception.Create(BITMAP_EMPTY);
W := fBitmap.Width;
WW := W div 8;
if (W mod 8) > 0 then
Inc(WW);
case fBitmap.PixelFormat of
pf1bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(1, 1, WW);
fConvertImageTo1And8BitPCXData(WW);
fGetPalette(2);
end;
pf4bit:
begin
// I don't have 4-bit PCX images to test with
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf8bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(8, 1, W);
fConvertImageTo1And8BitPCXData(W);
fGetPalette(256);
end;
pf15bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf16bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf24bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf32bit:&nbs
--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце.
|
|
|
|
| Правила форума "Delphi: Общие вопросы" |
 
 
|
Запрещается!
1. Публиковать ссылки на вскрытые компоненты
2. Обсуждать взлом компонентов и делиться вскрытыми компонентами
- Литературу по Дельфи обсуждаем здесь
- Действия модераторов можно обсудить здесь
- С просьбами о написании курсовой, реферата и т.п. обращаться сюда
- Вопросы по реализации алгоритмов рассматриваются здесь
- 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи
Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.
|
|
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
|
|
0 Пользователей:
|
|
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »
|
|
|
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности
Powered by Invision Power Board(R) 1.3 © 2003 IPS, Inc. |
|
|
Компонент для работы с PCX файлами 
Загрузка ...
