Author: Maarten de Haan
PCX image component. Fully supports reading and writing of: 1, 8 and 24 bit PCX
images.
Answer:
1
2 ///////////////////////////////////////////////////////////////////////
3 // //
4 // TPCXImage //
5 // ========= //
6 // //
7 // Completed: The 10th of August 2001 //
8 // Author: M. de Haan //
9 // Email: M.deHaan@inn.nl //
10 // Tested: under W95 SP1, NT4 SP6, WIN2000 //
11 // Version: 1.0 //
12 //-------------------------------------------------------------------//
13 // Update: The 14th of August 2001 to version 1.1. //
14 // Reason: Added version check. //
15 // Added comment info on version. //
16 // Changed PCX header ID check. //
17 //-------------------------------------------------------------------//
18 // Update: The 19th of August 2001 to version 2.0. //
19 // Reason: Warning from Delphi about using abstract methods, //
20 // caused by not implementing ALL TGraphic methods. //
21 // (Thanks goes to R.P. Sterkenburg for his diagnostic.) //
22 // Added: SaveToClipboardFormat, LoadFromClipboardFormat, //
23 // GetEmpty. //
24 //-------------------------------------------------------------------//
25 // Update: The 13th of October 2001 to version 2.1. //
26 // Reason: strange errors, read errors, EExternalException, IDE //
27 // hanging, Delphi hanging, Debugger hanging, windows //
28 // hanging, keyboard locked, and so on. //
29 // Changed: Assign procedure. //
30 //-------------------------------------------------------------------//
31 // Update: The 5th of April 2002 to version 2.2. //
32 // Changed: RLE compressor routine. //
33 // Reason: Incompatibility problems with other programs caused //
34 // by the RLE compressor. //
35 // Other programs encode: $C0 as: $C1 $C0. //
36 // ($C0 means: repeat the following byte 0 times //
37 // $C1 means: repeat the following byte 1 time.) //
38 // Changed: File read routine. //
39 // Reason: Now detects unsupported PCX data formats. //
40 // Added: 'Unsupported data format' in exception handler. //
41 // Added: 1 bit PCX support in reading. //
42 // Added: Procedure Convert1BitPCXDataToImage. //
43 // Renamed: Procedure ConvertPCXDataToImage to //
44 // Convert24BitPCXDataToImage. //
45 //-------------------------------------------------------------------//
46 // Update: The 14th of April 2002 to version 2.3. //
47 // Now capable of reading and writing 1 and 24 bit PCX //
48 // images. //
49 // Added: 1 bit PCX support in writing. //
50 // Added: Procedure ConvertImageTo1bitPCXData. //
51 // Changed: Procedure CreatePCXHeader. //
52 // Changed: Procedure TPCXImage.SaveToFile. //
53 //-------------------------------------------------------------------//
54 // Update: The 19th of April 2002 to version 2.4. //
55 // Now capable of reading and writing: 1, 8 and 24 bit //
56 // PCX images. //
57 // Added: 8 bit PCX support in reading and writing. //
58 // Renamed: Procedure ConvertImageTo1And8bitPCXData. //
59 // Renamed: Procedure Convert1And8bitPCXDataToImage. //
60 // Changed: Procedure fSetPalette, fGetPalette. //
61 //-------------------------------------------------------------------//
62 // Update: The 7th of May 2002 to version 2.5. //
63 // Reason: The palette of 8-bit PCX images couldn't be read in //
64 // the calling program. //
65 // Changed: Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
66 // Tested: All formats were tested with the following programs: //
67 // - import in Word 97, //
68 // * (Word ignores the palette of 1 bit PCX images!) //
69 // - import and export in MigroGrafX. //
70 // * (MicroGrafX also ignores the palette of 1 bit PCX //
71 // images.) //
72 // No problems were detected. //
73 // //
74 //===================================================================//
75 // //
76 // The PCX image file format is copyrighted by: //
77 // ZSoft, PC Paintbrush, PC Paintbrush plus //
78 // Trademarks: N/A //
79 // Royalty fees: NONE //
80 // //
81 //===================================================================//
82 // //
83 // The author can not be held responsable for using this software //
84 // in anyway. //
85 // //
86 // The features and restrictions of this component are: //
87 // ---------------------------------------------------- //
88 // //
89 // The reading and writing (import / export) of files / images: //
90 // - PCX version 5 definition, PC Paintbrush 3 and higher, //
91 // - RLE-compressed, //
92 // - 1 and 8 bit PCX images WITH palette and //
93 // - 24 bit PCX images without palette, //
94 // are supported by this component. //
95 // //
96 // Known issues //
97 // ------------ //
98 // //
99 // 1) GetEmpty is NOT tested. //
100 // //
101 // 2) SaveToClipboardFormat is NOT tested. //
102 // //
103 // 3) LoadFromClipboardFormat is NOT tested. //
104 // //
105 // 4) 4 bit PCX images (with palette) are NOT (yet) implemented. //
106 // (I have no 4-bit PCX images to test it on...) //
107 // //
108 ///////////////////////////////////////////////////////////////////////
109
110 unit
111 PCXImage;
112
113 interface
114
115 uses
116 Windows,
117 SysUtils,
118 Classes,
119 Graphics;
120
121 const
122 WIDTH_OUT_OF_RANGE = 'Illegal width entry in PCX file header';
123 HEIGHT_OUT_OF_RANGE = 'Illegal height entry in PCX file header';
124 FILE_FORMAT_ERROR = 'Invalid file format';
125 VERSION_ERROR = 'Only PC Paintbrush (plus) V3.0 and ' +
126 'higher are supported';
127 FORMAT_ERROR = 'Illegal identification byte in PCX file' +
128 ' header';
129 PALETTE_ERROR = 'Invalid palette signature found';
130 ASSIGN_ERROR = 'Can only Assign a TBitmap or a TPicture';
131 ASSIGNTO_ERROR = 'Can only AssignTo a TBitmap';
132 PCXIMAGE_EMPTY = 'The PCX image is empty';
133 BITMAP_EMPTY = 'The bitmap is empty';
134 INPUT_FILE_TOO_LARGE = 'The input file is too large to be read';
135 IMAGE_WIDTH_TOO_LARGE = 'Width of PCX image is too large to handle';
136 // added 19/08/2001
137 CLIPBOARD_LOAD_ERROR = 'Loading from clipboard failed';
138 // added 19/08/2001
139 CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
140 // added 14/10/2001
141 PCX_WIDTH_ERROR = 'Unexpected line length in PCX data';
142 PCX_HEIGHT_ERROR = 'More PCX data found than expected';
143 PCXIMAGE_TOO_LARGE = 'PCX image is too large';
144 // added 5/4/2002
145 ERROR_UNSUPPORTED = 'Unsupported PCX format';
146
147 const
148 sPCXImageFile = 'PCX V3.0+ image';
149
150 // added 19/08/2001
151 var
152 CF_PCX: WORD;
153
154 ///////////////////////////////////////////////////////////////////////
155 // //
156 // PCXHeader //
157 // //
158 ///////////////////////////////////////////////////////////////////////
159
160 type
161 QWORD = Cardinal; // Seems more logical to me...
162
163 type
164 fColorEntry = packed record
165 ceRed: BYTE;
166 ceGreen: BYTE;
167 ceBlue: BYTE;
168 end; // of packed record fColorEntry
169
170 type
171 TPCXImageHeader = packed record
172 fID: BYTE;
173 fVersion: BYTE;
174 fCompressed: BYTE;
175 fBitsPerPixel: BYTE;
176 fWindow: packed record
177 wLeft,
178 wTop,
179 wRight,
180 wBottom: WORD;
181 end; // of packed record fWindow
182 fHorzResolution: WORD;
183 fVertResolution: WORD;
184 fColorMap: array[0..15] of fColorEntry;
185 fReserved: BYTE;
186 fPlanes: BYTE;
187 fBytesPerLine: WORD;
188 fPaletteInfo: WORD;
189 fFiller: array[0..57] of BYTE;
190 end; // of packed record TPCXImageHeader
191
192 ///////////////////////////////////////////////////////////////////////
193 // //
194 // PCXData //
195 // //
196 ///////////////////////////////////////////////////////////////////////
197
198 type
199 TPCXData = object
200 fData: array of BYTE;
201 end; // of Type TPCXData
202
203 ///////////////////////////////////////////////////////////////////////
204 // //
205 // ScanLine //
206 // //
207 ///////////////////////////////////////////////////////////////////////
208
209 const
210 fMaxScanLineLength = $FFF; // Max image width: 4096 pixels
211
212 type
213 mByteArray = array[0..fMaxScanLineLength] of BYTE;
214 pmByteArray = ^mByteArray;
215
216 // The "standard" pByteArray from Delphi allocates 32768 bytes,
217 // which is a little bit overdone here, I think...
218
219 const
220 fMaxImageWidth = $FFF; // Max image width: 4096 pixels
221
222 type
223 xByteArray = array[0..fMaxImageWidth] of BYTE;
224
225 ///////////////////////////////////////////////////////////////////////
226 // //
227 // PCXPalette //
228 // //
229 ///////////////////////////////////////////////////////////////////////
230
231 type
232 TPCXPalette = packed record
233 fSignature: BYTE;
234 fPalette: array[0..255] of fColorEntry;
235 end; // of packed record TPCXPalette
236
237 ///////////////////////////////////////////////////////////////////////
238 // //
239 // Classes //
240 // //
241 ///////////////////////////////////////////////////////////////////////
242
243 type
244 TPCXImage = class;
245 TPCXFile = class;
246
247 ///////////////////////////////////////////////////////////////////////
248 // //
249 // PCXFile //
250 // //
251 // File handler //
252 // //
253 ///////////////////////////////////////////////////////////////////////
254
255 TPCXFile = class(TPersistent)
256
257 private
258 fHeight: Integer;
259 fWidth: Integer;
260 fPCXHeader: TPCXImageHeader;
261 fPCXData: TPCXData;
262 fPCXPalette: TPCXPalette;
263 fColorDepth: QWORD;
264 fPixelFormat: BYTE; // added 5/4/2002
265 fCurrentPos: QWORD;
266 fHasPalette: Boolean; // added 7/5/2002
267
268 protected
269 // Protected declarations
270
271 public
272 // Public declarations
273 constructor Create;
274 destructor Destroy; override;
275 procedure LoadFromFile(const Filename: string);
276 procedure LoadFromStream(Stream: TStream);
277 procedure SaveToFile(const Filename: string);
278 procedure SaveToStream(Stream: TStream);
279
280 published
281 // Published declarations
282 // The publishing is done in the TPCXImage section
283
284 end;
285
286 ///////////////////////////////////////////////////////////////////////
287 // //
288 // TPCXImage //
289 // //
290 // Image handler //
291 // //
292 ///////////////////////////////////////////////////////////////////////
293
294 TPCXImage = class(TGraphic)
295
296 private
297 // Private declarations
298 fBitmap: TBitmap;
299 fPCXFile: TPCXFile;
300 fRLine: xByteArray;
301 fGLine: xByteArray;
302 fBLine: xByteArray;
303 fP: pmByteArray;
304 fhPAL: HPALETTE;
305
306 procedure fConvert24BitPCXDataToImage;
307 procedure fConvert1And8BitPCXDataToImage;
308 procedure fConvertImageTo24BitPCXData;
309 procedure fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
310 QWORD);
311 procedure fFillDataLines(const fLine: array of BYTE);
312 procedure fCreatePCXHeader(const byBitsPerPixel: BYTE;
313 const byPlanes: BYTE; const wBytesPerLine: DWORD);
314 procedure fSetPalette(const wNumColors: WORD);
315 procedure fGetPalette(const wNumColors: WORD);
316 function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
317 function fGetBitmap: TBitmap; // Added 07/05/2002
318
319 protected
320 // Protected declarations
321 procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
322 function GetHeight: Integer; override;
323 function GetWidth: Integer; override;
324 procedure SetHeight(Value: Integer); override;
325 procedure SetWidth(Value: Integer); override;
326 function GetEmpty: Boolean; override;
327
328 public
329 // Public declarations
330 constructor Create; override;
331 destructor Destroy; override;
332 procedure Assign(Source: TPersistent); override;
333 procedure AssignTo(Dest: TPersistent); override;
334 procedure LoadFromFile(const Filename: string); override;
335 procedure LoadFromStream(Stream: TStream); override;
336 procedure SaveToFile(const Filename: string); override;
337 procedure SaveToStream(Stream: TStream); override;
338 procedure LoadFromClipboardFormat(AFormat: WORD;
339 AData: THandle; APalette: HPALETTE); override;
340 procedure SaveToClipboardFormat(var AFormat: WORD;
341 var AData: THandle; var APalette: HPALETTE); override;
342
343 published
344 // Published declarations
345 property Height: Integer
346 read GetHeight write SetHeight;
347 property Width: Integer
348 read GetWidth write SetWidth;
349 property PixelFormat: TPixelFormat
350 read fGetPixelFormat;
351 property Bitmap: TBitmap
352 read fGetBitmap; // Added 7/5/2002
353
354 end;
355
356 implementation
357
358 ///////////////////////////////////////////////////////////////////////
359 // //
360 // TPCXImage //
361 // //
362 // Image handler //
363 // //
364 ///////////////////////////////////////////////////////////////////////
365
366 constructor TPCXImage.Create;
367
368 begin
369 inherited Create;
370 // Init HPALETTE
371 fhPAL := 0;
372
373 // Create a private bitmap to hold the image
374 if not Assigned(fBitmap) then
375 fBitmap := TBitmap.Create;
376
377 // Create the PCXFile
378 if not Assigned(fPCXFile) then
379 fPCXFile := TPCXFile.Create;
380
381 end;
382 //---------------------------------------------------------------------
383
384 destructor TPCXImage.Destroy;
385
386 begin
387 // Reversed order of create
388 // Free fPCXFile
389 fPCXFile.Free;
390 // Free private bitmap
391 fBitmap.Free;
392 // Delete palette
393 if fhPAL <> 0 then
394 DeleteObject(fhPAL);
395 // Distroy all the other things
396 inherited Destroy;
397 end;
398 //---------------------------------------------------------------------
399
400 procedure TPCXImage.SetHeight(Value: Integer);
401
402 begin
403 if Value >= 0 then
404 fBitmap.Height := Value;
405 end;
406 //---------------------------------------------------------------------
407
408 procedure TPCXImage.SetWidth(Value: Integer);
409
410 begin
411 if Value >= 0 then
412 fBitmap.Width := Value;
413 end;
414 //---------------------------------------------------------------------
415
416 function TPCXImage.GetHeight: Integer;
417
418 begin
419 Result := fPCXFile.fHeight;
420 end;
421 //---------------------------------------------------------------------
422
423 function TPCXImage.GetWidth: Integer;
424
425 begin
426 Result := fPCXFile.fWidth;
427 end;
428 //---------------------------------------------------------------------
429
430 function TPCXImage.fGetBitmap: TBitmap;
431
432 begin
433 Result := fBitmap;
434 end;
435 //-------------------------------------------------------------------//
436 // The credits for this procedure go to his work of TGIFImage by //
437 // Reinier P. Sterkenburg //
438 // Added 19/08/2001 //
439 //-------------------------------------------------------------------//
440 // NOT TESTED!
441
442 procedure TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
443 ADAta: THandle; APalette: HPALETTE);
444
445 var
446 Size: QWORD;
447 Buf: Pointer;
448 Stream: TMemoryStream;
449 BMP: TBitmap;
450
451 begin
452 if (AData = 0) then
453 AData := GetClipBoardData(AFormat);
454 if (AData <> 0) and (AFormat = CF_PCX) then
455 begin
456 Size := GlobalSize(AData);
457 Buf := GlobalLock(AData);
458 try
459 Stream := TMemoryStream.Create;
460 try
461 Stream.SetSize(Size);
462 Move(Buf^, Stream.Memory^, Size);
463 Self.LoadFromStream(Stream);
464 finally
465 Stream.Free;
466 end;
467 finally
468
469 GlobalUnlock(AData);
470 end;
471 end
472 else if (AData <> 0) and (AFormat = CF_BITMAP) then
473 begin
474 BMP := TBitmap.Create;
475 try
476 BMP.LoadFromClipboardFormat(AFormat, AData, APalette);
477 Self.Assign(BMP);
478 finally
479 BMP.Free;
480 end;
481 end
482 else
483 raise Exception.Create(CLIPBOARD_LOAD_ERROR);
484 end;
485 //-------------------------------------------------------------------//
486 // The credits for this procedure go to his work of TGIFImage by //
487 // Reinier P. Sterkenburg //
488 // Added 19/08/2001 //
489 //-------------------------------------------------------------------//
490 // NOT TESTED!
491
492 procedure TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
493 var AData: THandle; var APalette: HPALETTE);
494
495 var
496 Stream: TMemoryStream;
497 Data: THandle;
498 Buf: Pointer;
499
500 begin
501 if Empty then
502 Exit;
503 // First store the bitmap to the clipboard
504 fBitmap.SaveToClipboardFormat(AFormat, AData, APalette);
505 // Then try to save the PCX
506 Stream := TMemoryStream.Create;
507 try
508 SaveToStream(Stream);
509 Stream.Position := 0;
510 Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
511 try
512 if Data <> 0 then
513 begin
514 Buf := GlobalLock(Data);
515 try
516 Move(Stream.Memory^, Buf^, Stream.Size);
517 finally
518 GlobalUnlock(Data);
519 end;
520 if SetClipBoardData(CF_PCX, Data) = 0 then
521 raise Exception.Create(CLIPBOARD_SAVE_ERROR);
522 end;
523 except
524 GlobalFree(Data);
525 raise;
526 end;
527 finally
528 Stream.Free;
529 end;
530 end;
531 //-------------------------------------------------------------------//
532 // NOT TESTED!
533
534 function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002
535
536 begin
537 if Assigned(fBitmap) then
538 Result := fBitmap.Empty
539 else
540 Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
541 end;
542 //---------------------------------------------------------------------
543
544 procedure TPCXImage.SaveToFile(const Filename: string);
545
546 var
547 fPCX: TFileStream;
548 W, WW: QWORD;
549
550 begin
551 if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
552 raise Exception.Create(BITMAP_EMPTY);
553 W := fBitmap.Width;
554 WW := W div 8;
555 if (W mod 8) > 0 then
556 Inc(WW);
557 case fBitmap.PixelFormat of
558 pf1bit:
559 begin
560 // Fully supported by PCX and by this component
561 fCreatePCXHeader(1, 1, WW);
562 fConvertImageTo1And8BitPCXData(WW);
563 fGetPalette(2);
564 end;
565 pf4bit:
566 begin
567 // I don't have 4-bit PCX images to test with
568 // It will be treated as a 24 bit image
569 fCreatePCXHeader(8, 3, W);
570 fConvertImageTo24BitPCXData;
571 end;
572 pf8bit:
573 begin
574 // Fully supported by PCX and by this component
575 fCreatePCXHeader(8, 1, W);
576 fConvertImageTo1And8BitPCXData(W);
577 fGetPalette(256);
578 end;
579 pf15bit:
580 begin
581 // Is this supported in PCX?
582 // It will be treated as a 24 bit image
583 fCreatePCXHeader(8, 3, W);
584 fConvertImageTo24BitPCXData;
585 end;
586 pf16bit:
587 begin
588 // Is this supported in PCX?
589 // It will be treated as a 24 bit image
590 fCreatePCXHeader(8, 3, W);
591 fConvertImageTo24BitPCXData;
592 end;
593 pf24bit:
594 begin
595 // Fully supported by PCX and by this component
596 fCreatePCXHeader(8, 3, W);
597 fConvertImageTo24BitPCXData;
598 end;
599 pf32bit:
600 begin
601 // Not supported by PCX
602 fCreatePCXHeader(8, 3, W);
603 fConvertImageTo24BitPCXData;
604 end;
605 else
606 begin
607 fCreatePCXHeader(8, 3, W);
608 fConvertImageTo24BitPCXData;
609 end; // of else
610 end; // of Case
611 fPCX := TFileStream.Create(Filename, fmCreate);
612 try
613 fPCX.Position := 0;
614 SaveToStream(fPCX);
615 finally
616 fPCX.Free;
617 end; // of finally
618 SetLength(fPCXFile.fPCXData.fData, 0);
619 end; // of Procedure SaveToFile
620 //-------------------------------------------------------------------//
621
622 procedure TPCXImage.AssignTo(Dest: TPersistent);
623
624 var
625 bAssignToError: Boolean;
626
627 begin
628 bAssignToError := True;
629
630 if Dest is TBitmap then
631 begin
632 // The old AssignTo procedure was like this.
633 // But then the palette was couldn't be accessed in the calling
634 // program for some reason.
635 // --------------------------
636 // (Dest as TBitmap).Assign(fBitmap);
637 // If fBitmap.Palette <> 0 then
638 // (Dest as TBitmap).Palette := CopyPalette(fBitmap.Palette);
639 // --------------------------
640
641 // Do the assigning
642 (Dest as TBitmap).Assign(fBitmap);
643
644 if fPCXFile.fHasPalette then
645 (Dest as TBitmap).Palette := CopyPalette(fhPAL);
646 // Now the calling program can access the palette
647 // (if it has one)!
648 bAssignToError := False;
649 end;
650
651 if Dest is TPicture then
652 begin
653 (Dest as TPicture).Graphic.Assign(fBitmap);
654 bAssignToError := False;
655 end;
656
657 if bAssignToError then
658 raise Exception.Create(ASSIGNTO_ERROR);
659
660 // You can write other assignments here, if you want...
661
662 end;
663 //-------------------------------------------------------------------//
664
665 procedure TPCXImage.Assign(Source: TPersistent);
666
667 var
668 iX, iY: DWORD;
669 bAssignError: Boolean;
670
671 begin
672 bAssignError := True;
673
674 if (Source is TBitmap) then
675 begin
676 fBitmap.Assign(Source as TBitmap);
677 if (Source as TBitmap).Palette <> 0 then
678 begin
679 fhPAL := CopyPalette((Source as TBitmap).Palette);
680 fBitmap.Palette := fhPAL;
681 end;
682 bAssignError := False;
683 end;
684
685 if (Source is TPicture) then
686 begin
687 iX := (Source as TPicture).Width;
688 iY := (Source as TPicture).Height;
689 fBitmap.Width := iX;
690 fBitmap.Height := iY;
691 fBitmap.Canvas.Draw(0, 0, (Source as TPicture).Graphic);
692 bAssignError := False;
693 end;
694
695 // You can write other assignments here, if you want...
696
697 if bAssignError then
698 raise Exception.Create(ASSIGN_ERROR);
699
700 end;
701 //---------------------------------------------------------------------
702
703 procedure TPCXImage.Draw(ACanvas: TCanvas; const Rect: TRect);
704
705 begin
706 // Faster
707 // ACanvas.Draw(0,0,fBitmap);
708
709 // Slower
710 ACanvas.StretchDraw(Rect, fBitmap);
711 end;
712 //---------------------------------------------------------------------
713
714 procedure TPCXImage.LoadFromFile(const Filename: string);
715
716 begin
717 fPCXFile.LoadFromFile(Filename);
718 // added 5/4/2002
719 case fPCXFile.fPixelFormat of
720 1: fConvert1And8BitPCXDataToImage;
721 8: fConvert1And8BitPCXDataToImage;
722 24: fConvert24BitPCXDataToImage;
723 end;
724 end;
725 //---------------------------------------------------------------------
726
727 procedure TPCXImage.SaveToStream(Stream: TStream);
728
729 begin
730 fPCXFile.SaveToStream(Stream);
731 end;
732 //---------------------------------------------------------------------
733
734 procedure TPCXImage.LoadFromStream(Stream: TStream);
735
736 begin
737 fPCXFile.LoadFromStream(Stream);
738 end;
739 ///////////////////////////////////////////////////////////////////////
740 // //
741 // Called by RLE compressor //
742 // //
743 ///////////////////////////////////////////////////////////////////////
744
745 procedure TPCXImage.fFillDataLines(const fLine: array of BYTE);
746
747 var
748 By: BYTE;
749 Cnt: WORD;
750 I: QWORD;
751 W: QWORD;
752
753 begin
754 I := 0;
755 By := fLine[0];
756 Cnt := $C1;
757 W := fBitmap.Width;
758
759 repeat
760
761 Inc(I);
762
763 if By = fLine[I] then
764 begin
765 Inc(Cnt);
766 if Cnt = $100 then
767 begin
768 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] :=
769 BYTE(Pred(Cnt));
770 Inc(fPCXFile.fCurrentPos);
771 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
772 Inc(fPCXFile.fCurrentPos);
773 Cnt := $C1;
774 By := fLine[I];
775 end;
776 end;
777
778 if (By <> fLine[I]) then
779 begin
780 if (Cnt = $C1) then
781 begin
782 // If (By < $C1) then
783 if (By < $C0) then // changed 5/4/2002
784 begin
785 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
786 Inc(fPCXFile.fCurrentPos);
787 end
788 else
789 begin
790 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
791 Inc(fPCXFile.fCurrentPos);
792 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
793 Inc(fPCXFile.fCurrentPos);
794 end;
795 end
796 else
797 begin
798 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
799 Inc(fPCXFile.fCurrentPos);
800 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
801 Inc(fPCXFile.fCurrentPos);
802 end;
803
804 Cnt := $C1;
805 By := fLine[I];
806 end;
807
808 until I = W - 1;
809
810 // Write the last byte(s)
811 if (Cnt > $C1) then
812 begin
813 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
814 Inc(fPCXFile.fCurrentPos);
815 end;
816
817 if (Cnt = $C1) and (By > $C0) then
818 begin
819 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
820 Inc(fPCXFile.fCurrentPos);
821 end;
822
823 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
824 Inc(fPCXFile.fCurrentPos);
825
826 end;
827 //-------------------------------------------------------------------//
828 // RLE Compression algorithm //
829 //-------------------------------------------------------------------//
830
831 procedure TPCXImage.fConvertImageTo24BitPCXData; // Renamed 5/4/2002
832
833 var
834 H, W: QWORD;
835 X, Y: QWORD;
836 I: QWORD;
837
838 begin
839 H := fBitmap.Height;
840 W := fBitmap.Width;
841 fPCXFile.fCurrentPos := 0;
842 SetLength(fPCXFile.fPCXData.fData, 6 * H * W); // To be sure...
843 fBitmap.PixelFormat := pf24bit; // Always do this if you're using
844 // ScanLine!
845
846 for Y := 0 to H - 1 do
847 begin
848 fP := fBitmap.ScanLine[Y];
849 I := 0;
850 for X := 0 to W - 1 do
851 begin
852 fRLine[X] := fP[I];
853 Inc(I); // Extract a red line
854 fGLine[X] := fP[I];
855 Inc(I); // Extract a green line
856 fBLine[X] := fP[I];
857 Inc(I); // Extract a blue line
858 end;
859
860 fFillDataLines(fBLine); // Compress the blue line
861 fFillDataLines(fGLine); // Compress the green line
862 fFillDataLines(fRLine); // Compress the red line
863
864 end;
865
866 // Correct the length of fPCXData.fData
867 SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
868 end;
869 //-------------------------------------------------------------------//
870
871 procedure TPCXImage.fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
872 QWORD);
873
874 var
875 H, W, X, Y: QWORD;
876 oldByte, newByte: BYTE;
877 Cnt: BYTE;
878
879 begin
880 H := fBitmap.Height;
881 W := ImageWidthInBytes;
882 fPCXFile.fCurrentPos := 0;
883 SetLength(fPCXFile.fPCXData.fData, 2 * H * W); // To be sure...
884 oldByte := 0; // Otherwise the compiler issues a warning about
885 // oldByte not being initialized...
886 Cnt := $C1;
887 for Y := 0 to H - 1 do
888 begin
889 fP := fBitmap.ScanLine[Y];
890 for X := 0 to W - 1 do
891 begin
892
893 newByte := fP[X];
894
895 if X > 0 then
896 begin
897 if (Cnt = $FF) then
898 begin
899 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
900 Inc(fPCXFile.fCurrentPos);
901 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
902 Inc(fPCXFile.fCurrentPos);
903 Cnt := $C1;
904 end
905 else if newByte = oldByte then
906 Inc(Cnt);
907
908 if newByte <> oldByte then
909 begin
910 if (Cnt > $C1) or (oldByte >= $C0) then
911 begin
912 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
913 Inc(fPCXFile.fCurrentPos);
914 Cnt := $C1;
915 end;
916 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
917 Inc(fPCXFile.fCurrentPos);
918 end;
919
920 end;
921 oldByte := newByte;
922 end;
923 // Write last byte of line
924 if (Cnt > $C1) or (oldByte >= $C0) then
925 begin
926 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
927 Inc(fPCXFile.fCurrentPos);
928 Cnt := $C1;
929 end;
930
931 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
932 Inc(fPCXFile.fCurrentPos);
933 end;
934
935 // Write last byte of image
936 if (Cnt > $C1) or (oldByte >= $C0) then
937 begin
938 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
939 Inc(fPCXFile.fCurrentPos);
940 // Cnt := 1;
941 end;
942 fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
943 Inc(fPCXFile.fCurrentPos);
944
945 // Correct the length of fPCXData.fData
946 SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
947 end;
948 //-------------------------------------------------------------------//
949 // RLE Decompression algorithm //
950 //-------------------------------------------------------------------//
951
952 procedure TPCXImage.fConvert24BitPCXDataToImage; // Renamed 5/4/2002
953
954 var
955
956 I: QWORD;
957 By: BYTE;
958 Cnt: BYTE;
959 H, W: QWORD;
960 X, Y: QWORD;
961 K, L: QWORD;
962
963 begin
964 H := fPCXFile.fPCXHeader.fWindow.wBottom -
965 fPCXFile.fPCXHeader.fWindow.wTop + 1;
966 W := fPCXFile.fPCXHeader.fWindow.wRight -
967 fPCXFile.fPCXHeader.fWindow.wLeft + 1;
968 Y := 0; // First line of image
969 fBitmap.Width := W; // Set bitmap width
970 fBitmap.Height := H; // Set bitmap height
971 fBitmap.PixelFormat := pf24bit; // Always do this if you're using
972 // ScanLine!
973 I := 0; // Pointer to data byte of fPXCFile
974 repeat
975
976 // Process the red line
977 // ProcessLine(fRLine,W);
978
979 X := 0; // Pointer to position in Red / Green / Blue line
980 repeat
981 By := fPCXFile.fPCXData.fData[I];
982 Inc(I);
983
984 // one byte
985 if By < $C1 then
986 if X <= W then // added 5/4/2002
987 begin
988 fRLine[X] := By;
989 Inc(X);
990 end;
991
992 // multiple bytes (RLE)
993 if By > $C0 then
994 begin
995 Cnt := By and $3F;
996
997 By := fPCXFile.fPCXData.fData[I];
998 Inc(I);
999
1000 //FillChar(fRLine[J],Cnt,By);
1001 //Inc(J,Cnt);
1002
1003 for K := 1 to Cnt do
1004 if X <= W then // added 5/4/2002
1005 begin
1006 fRLine[X] := By;
1007 Inc(X);
1008 end;
1009
1010 end;
1011
1012 until X >= W;
1013
1014 // Process the green line
1015 // ProcessLine(fGLine,W);
1016
1017 X := 0;
1018 repeat
1019 By := fPCXFile.fPCXData.fData[I];
1020 Inc(I);
1021
1022 // one byte
1023 if By < $C1 then
1024 if X <= W then // added 5/4/2002
1025 begin
1026 fGLine[X] := By;
1027 Inc(X);
1028 end;
1029
1030 // multiple bytes (RLE)
1031 if By > $C0 then
1032 begin
1033 Cnt := By and $3F;
1034
1035 By := fPCXFile.fPCXData.fData[I];
1036 Inc(I);
1037
1038 for K := 1 to Cnt do
1039 if X <= W then // added 5/4/2002
1040 begin
1041 fGLine[X] := By;
1042 Inc(X);
1043 end;
1044
1045 end;
1046
1047 until X >= W;
1048
1049 // Process the blue line
1050 // ProcessLine(fBLine,W);
1051
1052 X := 0;
1053 repeat
1054 By := fPCXFile.fPCXData.fData[I];
1055 Inc(I);
1056
1057 // one byte
1058 if By < $C1 then
1059 if X <= W then // added 5/4/2002
1060 begin
1061 fBLine[X] := By;
1062 Inc(X);
1063 end;
1064
1065 // multiple bytes (RLE)
1066 if By > $C0 then
1067 begin
1068 Cnt := By and $3F;
1069
1070 By := fPCXFile.fPCXData.fData[I];
1071 Inc(I);
1072
1073 for K := 1 to Cnt do
1074 if X <= W then // added 5/4/2002
1075 begin
1076 fBLine[X] := By;
1077 Inc(X);
1078 end;
1079
1080 end;
1081
1082 until X >= W;
1083
1084 // Write the just processed data RGB lines to the bitmap
1085 fP := fBitmap.ScanLine[Y];
1086 L := 0;
1087 for X := 0 to W - 1 do
1088 begin
1089 fP[L] := fBLine[X];
1090 Inc(L);
1091 fP[L] := fGLine[X];
1092 Inc(L);
1093 fP[L] := fRLine[X];
1094 Inc(L);
1095 end;
1096
1097 Inc(Y); // Process the next RGB line
1098
1099 until Y >= H;
1100
1101 SetLength(fPCXFile.fPCXData.fData, 0);
1102end;
1103//-------------------------------------------------------------------//
1104
1105procedure TPCXImage.fConvert1And8BitPCXDataToImage; // added 5/4/2002
1106
1107var
1108 I, J: QWORD;
1109 By: BYTE;
1110 Cnt: BYTE;
1111 H, W, WW: QWORD;
1112 X, Y: QWORD;
1113
1114begin
1115 H := fPCXFile.fPCXHeader.fWindow.wBottom -
1116 fPCXFile.fPCXHeader.fWindow.wTop + 1;
1117 W := fPCXFile.fPCXHeader.fWindow.wRight -
1118 fPCXFile.fPCXHeader.fWindow.wLeft + 1;
1119 fBitmap.Width := W; // Set bitmap width
1120 fBitmap.Height := H; // Set bitmap height
1121 WW := W;
1122
1123 // 1 bit PCX
1124 if fPCXFile.fPixelFormat = 1 then
1125 begin
1126 // All 1 bit images have a palette
1127 fBitmap.PixelFormat := pf1bit; // Always do this if you're using
1128 // ScanLine!
1129 WW := W div 8; // Correct width for pf1bit
1130 if W mod 8 > 0 then
1131 begin
1132 Inc(WW);
1133 fBitMap.Width := WW * 8;
1134 end;
1135 fSetPalette(2);
1136 end;
1137
1138 // 8 bit PCX
1139 if fPCXFile.fPixelFormat = 8 then
1140 begin
1141 // All 8 bit images have a palette!
1142 // This is how to set the palette of a bitmap
1143 // 1. First set the bitmap to pf8bit;
1144 // 2. then set the palette of the bitmap;
1145 // 3. then set the pixels with ScanLine or with Draw.
1146 // If you do it with StretchDraw, it won't work. Don't ask me why.
1147 // If you don't do it in this order, it won't work either! You'll
1148 // get strange colors.
1149 fBitmap.PixelFormat := pf8bit; // Always do this if you're using
1150 // ScanLine!
1151 fSetPalette(256);
1152 end;
1153
1154 I := 0;
1155 Y := 0;
1156 repeat
1157 fP := fBitmap.ScanLine[Y];
1158 X := 0; // Pointer to position in line
1159 repeat
1160 By := fPCXFile.fPCXData.fData[I];
1161 Inc(I);
1162
1163 // one byte
1164 if By < $C1 then
1165 if X <= WW then
1166 begin
1167 fP[X] := By;
1168 Inc(X);
1169 end;
1170
1171 // multiple bytes (RLE)
1172 if By > $C0 then
1173 begin
1174 Cnt := By and $3F;
1175
1176 By := fPCXFile.fPCXData.fData[I];
1177 Inc(I);
1178
1179 for J := 1 to Cnt do
1180 if X <= WW then
1181 begin
1182 fP[X] := By;
1183 Inc(X);
1184 end;
1185
1186 end;
1187
1188 until X >= WW;
1189
1190 Inc(Y); // Next line
1191
1192 until Y >= H;
1193end;
1194//---------------------------------------------------------------------
1195
1196procedure TPCXImage.fCreatePCXHeader(const byBitsPerPixel: BYTE;
1197 const byPlanes: BYTE; const wBytesPerLine: DWORD);
1198
1199var
1200 H, W: WORD;
1201
1202begin
1203 W := fBitmap.Width;
1204 H := fBitmap.Height;
1205
1206 // PCX header
1207 fPCXFile.fPCXHeader.fID := BYTE($0A); // BYTE (1)
1208 fPCXFile.fPCXHeader.fVersion := BYTE(5); // BYTE (2)
1209 fPCXFile.fPCXHeader.fCompressed := BYTE(1); // BYTE (3)
1210 // 0 = uncompressed, 1 = compressed
1211 // Only RLE compressed files are supported by this component
1212 fPCXFile.fPCXHeader.fBitsPerPixel := BYTE(byBitsPerPixel);
1213 // BYTE (4)
1214 fPCXFile.fPCXHeader.fWindow.wLeft := WORD(0); // WORD (5,6)
1215 fPCXFile.fPCXHeader.fWindow.wTop := WORD(0); // WORD (7,8)
1216 fPCXFile.fPCXHeader.fWindow.wRight := WORD(W - 1); // WORD (9,10)
1217 fPCXFile.fPCXHeader.fWindow.wBottom := WORD(H - 1); // WORD (11,12)
1218 fPCXFile.fPCXHeader.fHorzResolution := WORD(72); // WORD (13,14)
1219 fPCXFile.fPCXHeader.fVertResolution := WORD(72); // WORD (15,16)
1220
1221 FillChar(fPCXFile.fPCXHeader.fColorMap, 48, 0); // Array of Byte
1222 // (17..64)
1223
1224 fPCXFile.fPCXHeader.fReserved := BYTE(0); // BYTE (65)
1225 fPCXFile.fPCXHeader.fPlanes := BYTE(byPlanes);
1226 // BYTE (66)
1227 fPCXFile.fPCXHeader.fBytesPerLine := WORD(wBytesPerLine);
1228 // WORD (67,68)
1229 // must be even
1230 // rounded above
1231 fPCXFile.fPCXHeader.fPaletteInfo := WORD(1); // WORD (69,70)
1232
1233 FillChar(fPCXFile.fPCXHeader.fFiller, 58, 0); // Array of Byte
1234 // (71..128)
1235
1236 fPCXFile.fPixelFormat := fPCXFile.fPCXHeader.fPlanes *
1237 fPCXFile.fPCXHeader.fBitsPerPixel;
1238 fPCXFile.fColorDepth := 1 shl fPCXFile.fPixelFormat;
1239end;
1240//---------------------------------------------------------------------
1241(*
1242// From Delphi 5.0, graphics.pas
1243Function CopyPalette(Palette: HPALETTE): HPALETTE;
1244
1245Var
1246 PaletteSize : Integer;
1247 LogPal : TMaxLogPalette;
1248
1249Begin
1250Result := 0;
1251If Palette = 0 then
1252 Exit;
1253PaletteSize := 0;
1254If GetObject(Palette,SizeOf(PaletteSize),@PaletteSize) = 0 then
1255 Exit;
1256If PaletteSize = 0 then
1257 Exit;
1258With LogPal do
1259 Begin
1260 palVersion := $0300;
1261 palNumEntries := PaletteSize;
1262 GetPaletteEntries(Palette,0,PaletteSize,palPalEntry);
1263 End;
1264Result := CreatePalette(PLogPalette(@LogPal)^);
1265End;
1266*)
1267//---------------------------------------------------------------------
1268// From Delphi 5.0, graphics.pas
1269(*
1270Procedure TPCXImage.fSetPixelFormat(Value : TPixelFormat);
1271
1272Const
1273 BitCounts : Array [pf1Bit..pf32Bit] of BYTE = (1,4,8,16,16,24,32);
1274
1275Var
1276 DIB : TDIBSection;
1277 Pal : HPALETTE;
1278 DC : hDC;
1279 KillPal : Boolean;
1280
1281Begin
1282If Value = GetPixelFormat then
1283 Exit;
1284Case Value of
1285 pfDevice : Begin
1286 HandleType := bmDDB;
1287 Exit;
1288 End;
1289 pfCustom : InvalidGraphic(@SInvalidPixelFormat);
1290 else
1291 FillChar(DIB,sizeof(DIB), 0);
1292
1293 DIB.dsbm := FImage.FDIB.dsbm;
1294 KillPal := False;
1295 With DIB, dsbm,dsbmih do
1296 Begin
1297 bmBits := nil;
1298 biSize := SizeOf(DIB.dsbmih);
1299 biWidth := bmWidth;
1300 biHeight := bmHeight;
1301 biPlanes := 1;
1302 biBitCount := BitCounts[Value];
1303 Pal := FImage.FPalette;
1304 Case Value of
1305 pf4Bit : Pal := SystemPalette16;
1306 pf8Bit : Begin
1307 DC := GDICheck(GetDC(0));
1308 Pal := CreateHalftonePalette(DC);
1309 KillPal := True;
1310 ReleaseDC(0, DC);
1311 End;
1312 pf16Bit : Begin
1313 biCompression := BI_BITFIELDS;
1314 dsBitFields[0] := $F800;
1315 dsBitFields[1] := $07E0;
1316 dsBitFields[2] := $001F;
1317 End;
1318 End; // of Case
1319 Try
1320 CopyImage(Handle, Pal, DIB);
1321 PaletteModified := (Pal <> 0);
1322 Finally
1323 if KillPal then
1324 DeleteObject(Pal);
1325 End; // of Try
1326 Changed(Self);
1327 End; // of With
1328 End; // of Case
1329End; // of Procedure
1330*)
1331//---------------------------------------------------------------------
1332
1333procedure TPCXImage.fSetPalette(const wNumColors: WORD);
1334
1335(* From Delphi 5.0, graphics.pas
1336
1337Type
1338 TPalEntry = packed record
1339 peRed : BYTE;
1340 peGreen : BYTE;
1341 peBlue : BYTE;
1342 End;
1343
1344Type
1345 tagLOGPALETTE = packed record
1346 palVersion : WORD;
1347 palNumEntries : WORD;
1348 palPalEntry : Array[0..255] of TPalEntry
1349 End;
1350
1351Type
1352 TMAXLogPalette = tagLOGPALETTE;
1353 PMAXLogPalette = ^TMAXLogPalette;
1354
1355Type
1356 PRGBQuadArray = ^TRGBQuadArray;
1357 TRGBQuadArray = Array[BYTE] of TRGBQuad;
1358
1359Type
1360 PRGBQuadArray = ^TRGBQuadArray;
1361 TRGBQuadArray = Array[BYTE] of TRGBQuad;
1362*)
1363
1364var
1365 pal: TMaxLogPalette;
1366 W: WORD;
1367
1368begin
1369 pal.palVersion := $300; // The "Magic" number
1370 pal.palNumEntries := wNumColors;
1371 for W := 0 to 255 do
1372 begin
1373 pal.palPalEntry[W].peRed :=
1374 fPCXFile.fPCXPalette.fPalette[W].ceRed;
1375 pal.palPalEntry[W].peGreen :=
1376 fPCXFile.fPCXPalette.fPalette[W].ceGreen;
1377 pal.palPalEntry[W].peBlue :=
1378 fPCXFile.fPCXPalette.fPalette[W].ceBlue;
1379 pal.palPalEntry[W].peFlags := 0;
1380 end;
1381
1382 (* Must we delete the old palette first here? I don't know.
1383 If fhPAL <> 0 then
1384 DeleteObject(fhPAL);
1385 *)
1386
1387 fhPAL := CreatePalette(PLogPalette(@pal)^);
1388 if fhPAL <> 0 then
1389 fBitmap.Palette := fhPAL;
1390end;
1391//---------------------------------------------------------------------
1392
1393function TPCXImage.fGetPixelFormat: TPixelFormat;
1394
1395// Only pf1bit, pf4bit and pf8bit images have a palette.
1396// pf15bit, pf16bit, pf24bit and pf32bit images have no palette.
1397// You can change the palette of pf1bit images in windows.
1398// The foreground color and the background color of pf1bit images
1399// do not have to be black and white. You can choose any tow colors.
1400// The palette of pf4bit images is fixed.
1401// The palette entries 0..9 and 240..255 of pf8bit images are reserved
1402// in windows.
1403begin
1404 Result := pfDevice;
1405 case fPCXFile.fPixelFormat of
1406 01: Result := pf1bit; // Implemented WITH palette.
1407 // 04 : Result := pf4bit; // Not yet implemented in this component,
1408 // is however implemented in PCX format.
1409 08: Result := pf8bit; // Implemented WITH palette.
1410 // 15 : Result := pf15bit; // Not implemented in PCX format?
1411 // 16 : Result := pf16bit; // Not implemented in PCX format?
1412 24: Result := pf24bit; // Implemented, has no palette.
1413 // 32 : Result := pf32bit; // Not implemented in PCX format.
1414 end;
1415end;
1416//---------------------------------------------------------------------
1417
1418procedure TPCXImage.fGetPalette(const wNumColors: WORD);
1419
1420var
1421 pal: TMaxLogPalette;
1422 W: WORD;
1423
1424begin
1425 fPCXFile.fPCXPalette.fSignature := $0C;
1426
1427 pal.palVersion := $300; // The "Magic" number
1428 pal.palNumEntries := wNumColors;
1429 GetPaletteEntries(CopyPalette(fBitmap.Palette), 0, wNumColors,
1430 pal.palPalEntry);
1431 for W := 0 to 255 do
1432 if W < wNumColors then
1433 begin
1434 fPCXFile.fPCXPalette.fPalette[W].ceRed :=
1435 pal.palPalEntry[W].peRed;
1436 fPCXFile.fPCXPalette.fPalette[W].ceGreen :=
1437 pal.palPalEntry[W].peGreen;
1438 fPCXFile.fPCXPalette.fPalette[W].ceBlue :=
1439 pal.palPalEntry[W].peBlue;
1440 end
1441 else
1442 begin
1443 fPCXFile.fPCXPalette.fPalette[W].ceRed := 0;
1444 fPCXFile.fPCXPalette.fPalette[W].ceGreen := 0;
1445 fPCXFile.fPCXPalette.fPalette[W].ceBlue := 0;
1446 end;
1447end;
1448//=====================================================================
1449
1450///////////////////////////////////////////////////////////////////////
1451// //
1452// TPCXFile //
1453// //
1454///////////////////////////////////////////////////////////////////////
1455
1456constructor TPCXFile.Create;
1457
1458begin
1459 inherited Create;
1460 fHeight := 0;
1461 fWidth := 0;
1462 fCurrentPos := 0;
1463end;
1464//---------------------------------------------------------------------
1465
1466destructor TPCXFile.Destroy;
1467
1468begin
1469 SetLength(fPCXData.fData, 0);
1470 inherited Destroy;
1471end;
1472//---------------------------------------------------------------------
1473
1474procedure TPCXFile.LoadFromFile(const Filename: string);
1475
1476var
1477 fPCXStream: TFileStream;
1478
1479begin
1480 fPCXStream := TFileStream.Create(Filename, fmOpenRead);
1481 try
1482 fPCXStream.Position := 0;
1483 LoadFromStream(fPCXStream);
1484 finally
1485 fPCXStream.Free;
1486 end;
1487end;
1488//---------------------------------------------------------------------
1489
1490procedure TPCXFile.SaveToFile(const Filename: string);
1491
1492var
1493 fPCXStream: TFileStream;
1494
1495begin
1496 fPCXStream := TFileStream.Create(Filename, fmCreate);
1497 try
1498 fPCXStream.Position := 0;
1499 SaveToStream(fPCXStream);
1500 finally
1501 fPCXStream.Free;
1502 end;
1503end;
1504//---------------------------------------------------------------------
1505
1506procedure TPCXFile.LoadFromStream(Stream: TStream);
1507
1508var
1509 fFileLength: Cardinal;
1510
1511begin
1512 // Read the PCX header
1513 Stream.read(fPCXHeader, SizeOf(fPCXHeader));
1514
1515 // Check the ID byte
1516 if fPCXHeader.fID <> $0A then
1517 raise Exception.Create(FORMAT_ERROR);
1518
1519 (*
1520 Check PCX version byte
1521 ======================
1522 Versionbyte = 0 => PC PaintBrush V2.5
1523 Versionbyte = 2 => PC Paintbrush V2.8 with palette information
1524 Versionbyte = 3 => PC Paintbrush V2.8 without palette information
1525 Versionbyte = 4 => PC Paintbrush for Windows
1526 Versionbyte = 5 => PC Paintbrush V3 and up, and PC Paintbrush Plus
1527 with 24 bit image support
1528 *)
1529 // Check the PCX version
1530 if fPCXHeader.fVersion <> 5 then
1531 raise Exception.Create(VERSION_ERROR);
1532
1533 // Calculate width
1534 fWidth := fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;
1535 if fWidth < 0 then
1536 raise Exception.Create(WIDTH_OUT_OF_RANGE);
1537
1538 // Calculate height
1539 fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
1540 if fHeight < 0 then
1541 raise Exception.Create(HEIGHT_OUT_OF_RANGE);
1542
1543 // Is it too large?
1544 if fWidth > fMaxImageWidth then
1545 raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);
1546
1547 // Calculate pixelformat
1548 fPixelFormat := fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel;
1549
1550 // Calculate number of colors
1551 fColorDepth := 1 shl fPixelFormat;
1552
1553 // Is this image supported?
1554 if not (fPixelFormat in [1, 8, 24]) then
1555 raise Exception.Create(ERROR_UNSUPPORTED);
1556
1557 // The lines following are NOT tested!!!
1558 (*
1559 If fColorDepth <= 16 then
1560 For I := 0 to fColorDepth - 1 do
1561 Begin
1562 If fPCXHeader.fVersion = 3 then
1563 Begin
1564 fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R shl 2;
1565 fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G shl 2;
1566 fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B shl 2;
1567 End
1568 else
1569 Begin
1570 fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R;
1571 fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G;
1572 fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B;
1573 End;
1574 End;
1575 *)
1576
1577 // Calculate number of data bytes
1578
1579 // If fFileLength > fMaxDataFileLength then
1580 // Raise Exception.Create(INPUT_FILE_TOO_LARGE);
1581
1582 if fPixelFormat = 24 then
1583 begin
1584 fFileLength := Stream.Size - Stream.Position;
1585 SetLength(fPCXData.fData, fFileLength);
1586 // Read the data
1587 Stream.read(fPCXData.fData[0], fFileLength);
1588 fHasPalette := False;
1589 end;
1590
1591 if fPixelFormat in [1, 8] then
1592 begin
1593 fFileLength := Stream.Size - Stream.Position - 769;
1594 SetLength(fPCXData.fData, fFileLength);
1595 // Correct number of data bytes
1596 Stream.read(fPCXData.fData[0], fFilelength);
1597 // Read the palette
1598 Stream.read(fPCXPalette, SizeOf(fPCXPalette));
1599 fHasPalette := True;
1600 // Check palette signature byte
1601 if fPCXPalette.fSignature <> $0C then
1602 raise Exception.Create(PALETTE_ERROR);
1603 end;
1604
1605end;
1606//---------------------------------------------------------------------
1607
1608procedure TPCXFile.SaveToStream(Stream: TStream);
1609
1610begin
1611 fHasPalette := False;
1612 Stream.write(fPCXHeader, SizeOf(fPCXHeader));
1613 Stream.write(fPCXData.fData[0], fCurrentPos);
1614 if fPixelFormat in [1, 8] then
1615 begin
1616 Stream.write(fPCXPalette, SizeOf(fPCXPalette));
1617 fHasPalette := True;
1618 end;
1619end;
1620//---------------------------------------------------------------------
1621// Register PCX format
1622initialization
1623 TPicture.RegisterFileFormat('PCX', sPCXImageFile, TPCXImage);
1624 CF_PCX := RegisterClipBoardFormat('PCX Image');
1625 TPicture.RegisterClipBoardFormat(CF_PCX, TPCXImage);
1626 //---------------------------------------------------------------------
1627 // Unregister PCX format
1628finalization
1629 TPicture.UnRegisterGraphicClass(TPCXImage);
1630 //---------------------------------------------------------------------
1631end.
1632//=====================================================================
|
