pcx.pas

TeeChart7Source 控件

{ Davie Reed, January 1999 }
{ E-Mail:  [e-mail] }
{ Modified by David Berneda 2000-2004 }

unit PCX;
{$I TeeDefs.inc}

interface

Uses
   {$IFNDEF LINUX}
   Windows,
   {$ENDIF}
   Classes,
   {$IFDEF CLX}
   QGraphics
   {$ELSE}
   Graphics
   {$ENDIF};
{
{ Setup the following variable before calling LoadFromFileX
{
{ Global_KeepTrueFormat:Word
{ 0 = Use the files native bits per pixel for the TBitMap
{ 1 = Force TBitMap of 256 colors and use gray it file was 24bit
{ 2 = Force TBitMap to 24bit
{
{ SAVETOFILEX(parm1,parm2,parm3);
{    Parm1=Filename
{    Parm2=TBitMap to save
{    Parm3=Type of PCX file to create
{           1 = Save as 256 Color file
{           2 = Save as 16M file
{
{ ****************** ERROR HANDLING ******************
{ If you want a special message displayed if there is an error
{ while saving a PCX, then search for    ###ERROR###    and you will
{ find the block of code that has nothing in it currently. Just put in
{ whatever logic you like. For example: An error message :)
}

Procedure LoadFromFileX(const FileName:String; Const BitMap:TBitMap);
Procedure TeePCXToStream(Stream:TStream; Const BitMap:TBitMap; PcxType:Byte);
Procedure SaveToFileX(const FileName:String; Const BitMap:TBitMap; PcxType:Byte);

implementation

Type
   TypeRegVer=Set Of (Non_Registered,Registered,OEM,PRO,SYSOP);
   DataLineArray=Array[0..65535] Of Byte;
   DataWordArray=Array[0..65535] Of SmallInt;
   FakePalette= Packed Record
      LPal : TLogPalette;
      Dummy:Array[1..255] of TPaletteEntry;
      End;

   TypeEgaPalette=Array[0..16] Of Byte;
   TypePalette=Array[0..255,1..3] Of Byte;

Const
   Global_HiColor=3;
   Global_KeepTrueFormat:Word=0;

   Global_PaletteDef:Array[0..15,1..3] Of Byte = (
{Black}                                       (0  ,0  ,0 ),
{Blue}                                        (0  ,0  ,32),
{Green}                                       (0  ,32 ,0 ),
{Cyan}                                        (0  ,32 ,32),
{Red}                                         (32 ,0  ,0 ),
{Magenta}                                     (32 ,0  ,32),
{Brown}                                       (32 ,32 ,0 ),
{Light Gray}                                  (42 ,42 ,42),
{Dark Gray}                                   (21 ,21 ,21),
{Light Blue}                                  (0  ,0  ,63),
{Light Green}                                 (0  ,63 ,0 ),
{Light Cyan}                                  (0  ,63 ,63),
{Light Red}                                   (63 ,0  ,0 ),
{Light Magenta}                               (63 ,0  ,63),
{Yellow}                                      (63 ,63 ,0 ),
{Bright White}                                (63 ,63 ,63)
                                              );

Var
  PictureFile:File;
  PaletteVGA:TypePalette;
  SysPal:FakePalette;
  TempArrayD:^DataLineArray;
  TempArrayD2:^DataLineArray;
  TempArrayDBIg,TempArrayDBig16:^DataLineArray;
  ErrorString:ShortString;
  Width:Word;
  Height:Word;
  BitsPerPixel:SmallInt;
  MyKeepTrueFormat:Boolean;
  MyKeepTrueBits:Word;
Var
  PcxVersion:Word;
  PcxColorPlanes:Byte;
  PcxEncoding:Word;
  PcxBytesPerLine:Word;
  PcxPaletteType:Word;

Const
  Const4096=8*1024;
var
  Index1:Word=0;
  Index2:Word=0;
  IndexData:Array[0..Const4096-1] Of Byte;

Procedure FileGetMore;
Var
  NumRead:Integer;
Begin
FillChar(IndexData,Const4096,0);
BlockRead(PictureFile,IndexData,Const4096,NumRead);
Index1:=Const4096;
Index2:=0;
End;

(*
Procedure FastGetBytes(Var Ptr1;NumBytes:Word);
Var
  X:Integer;
Begin
{
{ If we have enough the block it!
{ Otherwise do one at a time!
}
If Index1<NumBytes Then
   Begin
   If Index1=0 Then
      Begin
      FileGetMore;
      End;
   For X:=0 To NumBytes-1 Do
       Begin
       DataLineArray(Ptr1)[X]:=IndexData[Index2];
       Inc(Index2);
       Dec(Index1);
       If Index1=0 Then
          FileGetMore;
       End;
   End
Else
   Begin
   {
   { Block it fast!
   }
   Move(IndexData[Index2],DataLineArray(Ptr1)[0],NumBytes);
   Index2:=Index2+Numbytes;
   Index1:=Index1-NumBytes;
   End;
End;
*)

Function FastGetByte:Byte;
Begin
If Index1=0 Then
   Begin
   FileGetMore;
   End;
FastGetByte:=IndexData[Index2];
Inc(Index2);
Dec(Index1);
End;

Function FastGetWord:Word;
Begin
FastGetWord:=Word(FastGetByte)+Word(FastGetByte)*256;
End;

Procedure FileIoReset;
Begin
Index1:=0;
Index2:=0;
End;

Procedure OpenFile(const FileName:String; Var FileOk:Boolean);
Var
  Io:Integer;
  OldFileMode:Word;
Begin
FileIoReset;
OldFileMode:=FileMode;
FileMode:=0;
AssignFile(PictureFile,FileName);
ReSet(PictureFile,1);
Io:=IoResult;
If Io<>0 Then
   Begin
   FileOk:=False;
   End;
FileMode:=OldFileMode;
End;

Procedure FillerUp(Var TempArrayD;Size:Word;B1:Byte);
Begin
FillChar(TempArrayD,Size,B1);
End;

Procedure ConvertXBitsToYBits(Var Input,Output:DataLineArray;Xbits,Ybits,Width:Word);
Var
  X,Z:Word;
  B1:Byte;
Begin
{
{ Generic converter to a single data line :)
{ Can go only from smaller bits to larger bits, otherwise you need to
{     dither down!
{ PaletteVGA MUST be setup already!
}
Case Xbits Of
     1:Begin
       Case Ybits Of
            4:Begin
              {
              { From 1 bit to 4 bit, hmmmmm EZ :)
              }
              For X:=0 To Width-1 Do
                  Begin
                  B1:=(Input[X Shr 3] Shr (7-(X Mod 8))) And 1;
                  OutPut[X Shr 1]:=OutPut[X Shr 1] Or (B1 Shl ((1-(X Mod 2))*4));
                  End;
              End;
            8:Begin
              {
              { From 1 bit to 8 bit, hmmmmm EZ :)
              }
              For X:=0 To Width-1 Do
                  Begin
                  B1:=(Input[X Shr 3] Shr (7-(X Mod 8) )) And 1;
                  OutPut[X]:=B1;
                  End;
              End;
           24:Begin
              {
              { From 1 bit to 8 bit, hmmmmm EZ :)
              }
              Z:=0;
              For X:=0 To Width-1 Do
                  Begin
                  B1:=((Input[X Shr 3] Shr (7-(X Mod 8))) And 1)*255;
                  OutPut[Z+0]:=B1;
                  OutPut[Z+1]:=B1;
                  OutPut[Z+2]:=B1;
                  Z:=Z+3;
                  End;
              End;
           End;
       End;
     4:Begin
       Case Ybits Of
            4:Begin
              Move(Input[0],Output[0],Width);
              End;
            8:Begin
              {
              { Go from 4 bits to 8 bit :)
              }
              For X:=0 To Width-1 Do
                  Begin
                  B1:=(Input[X Shr 1] Shr ((1-(X Mod 2))*4)) And $0F;
                  OutPut[X]:=B1;
                  End;
              End;
           24:Begin
              {
              { Go from 4 bits to 24 bit :)
              }
              Z:=0;
              For X:=0 To Width-1 Do
                  Begin
                  B1:=(Input[X Shr 1] Shr ((1-(X Mod 2))*4)) And $0F;
                  OutPut[Z+0]:=(PaletteVGA[B1,3]*255) Div 63;
                  OutPut[Z+1]:=(PaletteVGA[B1,2]*255) Div 63;
                  OutPut[Z+2]:=(PaletteVGA[B1,1]*255) Div 63;
                  Z:=Z+3;
                  End;
              End;
           End;
       End;
     8:Begin
       Case Ybits Of
            1:Begin
              For X:=0 To Width-1 Do
                  OutPut[X Shr 3]:=0;
              For X:=0 To Width-1 Do
                  Begin
                  B1:=InPut[X];
                  OutPut[X Shr 3]:=OutPut[X Shr 3] Or (B1 Shl (7-(X Mod 8)));
                  End;
              End;
            8:Begin
              Move(Input[0],Output[0],Width);
              End;
           24:Begin
              {
              { From 8 bit to 24 bit, hmmmmm 2EZ :)
              }
              Z:=0;
              For X:=0 To Width-1 Do
                  Begin
                  B1:=Input[X];
                  OutPut[Z+0]:=(PaletteVGA[B1,3]*255) Div 63;
                  OutPut[Z+1]:=(PaletteVGA[B1,2]*255) Div 63;
                  OutPut[Z+2]:=(PaletteVGA[B1,1]*255) Div 63;
                  Z:=Z+3;
                  End;
              End;
           End;
       End;
    24:Begin
       Case Ybits Of
            24:Begin
               Move(Input[0],Output[0],Width*3);
               End;
            End;
       End;
    End;
End;


Procedure SetUpMaskGrayPalette;
Var
  I,J:Word;
Begin
For J:=0 To 255 Do
    Begin
    For I:=1 To 3 Do
        Begin
        PaletteVga[J,I]:=J*63 Div 255;
        End;
    End;
End;

Function PCXGrayValue(R,G,B:Word):Word;
Begin
PCXGrayValue:=((R Shl 5)+(G Shl 6)+(B*12)) Div 108;
End;

Procedure MakePalBW(Const BitMap:TBitMap);
Begin
  SysPal.LPal.palVersion:=$300;
  SysPal.LPal.palNumEntries:=2;
  Syspal.LPal.PalPalEntry[0].peRed:=0;
  Syspal.LPal.PalPalEntry[0].peGreen:=0;
  Syspal.LPal.PalPalEntry[0].peBlue:=0;
  Syspal.LPal.PalPalEntry[0].peFlags:=0;
  Syspal.Dummy[1].peRed:=255;
  Syspal.Dummy[1].peGreen:=255;
  Syspal.Dummy[1].peBlue:=255;
  Syspal.Dummy[1].peFlags:=0;

  {$IFNDEF CLX}
  Bitmap.Palette:= CreatePalette(Syspal.LPal);
  {$ENDIF}
End;

Procedure MakePalPalette(Const BitMap:TBitMap);
Var I:Word;
Begin
  SysPal.LPal.palVersion:=$300;
  SysPal.LPal.palNumEntries:=256;
  For I:=0 To 255 Do
  Begin
      Syspal.LPal.PalPalEntry[I].peRed:=  (PaletteVga[I,1])*4;
      Syspal.LPal.PalPalEntry[I].peGreen:=(PaletteVga[I,2])*4;
      Syspal.LPal.PalPalEntry[I].peBlue:= (PaletteVga[I,3])*4;
      Syspal.LPal.PalPalEntry[I].peFlags:= 0;
  End;

  {$IFNDEF CLX}
  Bitmap.Palette:= CreatePalette(Syspal.LPal);
  {$ENDIF}
End;

(*
Procedure MakePalPaletteX(Const BitMap:TBitMap;HowMany:Word);
Var
  I:Word;
Begin
SysPal.LPal.palVersion:=$300;
SysPal.LPal.palNumEntries:=HowMany;
For I:=0 To HowMany-1 Do
    Begin
    Syspal.LPal.PalPalEntry[I].peRed:=  (PaletteVga[I,1])*4;
    Syspal.LPal.PalPalEntry[I].peGreen:=(PaletteVga[I,2])*4;
    Syspal.LPal.PalPalEntry[I].peBlue:= (PaletteVga[I,3])*4;
    Syspal.LPal.PalPalEntry[I].peFlags:= 0;
    End;
Bitmap.Palette:= CreatePalette(Syspal.LPal);
End;
*)

Procedure SaveThePalette(Const HPal:HPalette;Var SavePal:TypePalette);
Var
  I:Word;
Begin
For I:=0 To 255 Do
    Begin
    Syspal.LPal.PalPalEntry[I].peRed:=0;
    Syspal.LPal.PalPalEntry[I].peGreen:=0;
    Syspal.LPal.PalPalEntry[I].peBlue:=0;
    End;
GetPaletteEntries(HPal,0,256,SysPal.LPal.PalPalEntry[0]);
For I:=0 To 255 Do
    Begin
    SavePal[I,1]:=(((Syspal.LPal.PalPalEntry[I].peRed)) Div 4);
    SavePal[I,2]:=(((Syspal.LPal.PalPalEntry[I].peGreen)) Div 4);
    SavePal[I,3]:=(((Syspal.LPal.PalPalEntry[I].peBlue)) Div 4);
    End;
End;

Procedure MakeGenPalette;
Var
  X:Word;
  R,G,B:Word;
Begin
X:=0;
For R:=0 To 7 Do
    Begin
    For G:=0 To 7 Do
        Begin
        For B:=0 To 3 Do
            Begin
            PaletteVga[X,1]:=(R+1)*8-1;
            PaletteVga[X,2]:=(G+1)*8-1;
            PaletteVga[X,3]:=(B+1)*16-1;
            Inc(X);
            End;
        End;
    End;
End;

Function  ShouldIKeepTrueFormat(Var BPP:Word):Boolean;
Begin
{
{ Choices
{    Use File Colors
{    Force 256 Colors
{    Force 16M Colors
}
If Global_KeepTrueFormat=0 Then
   ShouldIKeepTrueFormat:=True
Else
   ShouldIKeepTrueFormat:=False;
If Global_KeepTrueFormat=1 Then
   BPP:=8;
If Global_KeepTrueFormat=2 Then
   BPP:=24;
End;

Procedure DetColorVGA (Var PValue:Byte;MapValue:Byte);
Begin
PValue:=MapValue Div 4;
End;

Procedure PaletteDefaults;
Var
  J,I:Word;
Begin
For J:=0 To 15 Do
    Begin
    For I:=1 To 3 Do
        PaletteVGA[J,I]:=Global_PaletteDef[J,I];
    End;
End;

Procedure SetUpMaskAndColorMap;
Var
  R,G,B,PalBlue,PalGreen,PalRed:Byte;
  I:Integer;
  ColorMapSize:Integer;

Begin
{
{ Handle black and white images
}
ColorMapSize:=1 shl BitsPerPixel;
If BitsPerPixel=24 Then
   SetUpMaskGrayPalette
Else
    Begin
    For I:=0 to ColorMapSize-1 do
    Begin
              PalRed  :=FastGetbyte;
              PalGreen:=FastGetbyte;
              PalBlue :=FastGetbyte;
              If PcxVersion=2 Then
                 Begin
                 If PalRed<4 Then
                    PalRed:=PalRed*$55;
                 If PalGreen<4 Then
                    PalGreen:=PalGreen*$55;
                 If PalBlue<4 Then
                    PalBlue:=PalBlue*$55;
                 End;

    DetColorVGA (R,PalRed  );
    DetColorVGA (G,PalGreen);
    DetColorVGA (B,PalBlue );

    PaletteVGA[I,1]:=R;
    PaletteVGA[I,2]:=G;
    PaletteVGA[I,3]:=B;
    End;
    End;
End;

{
============================================
}

Procedure ReadPCXLine;
Var
   N,MaximumN,Z:Word;
   I:SmallInt;
   TmpB1,B1,C,CurrentPlane:Byte;
   CX:SmallInt;
   RealWidth:Integer;
Begin
N:=0;
Z:=0;
CurrentPlane:=0;
MaximumN:=PCXBytesPerLine*PcxColorPlanes;
RealWidth:=PcxBytesPerLine*8;
Repeat
    Begin
    B1:=FastGetByte;
    If B1 And $C0=$C0 Then
       Begin
       I:=B1 And $3F;
       C:=FastGetByte;
       While I>0 Do
             Begin
             Case BitsPerPixel Of
                  1:Begin
                    If (MyKeepTrueFormat=True) And (PcxColorPlanes=1) Then
                       Begin
                       TempArrayDBIG[Z]:=TempArrayDBIG[Z]+C;
                       Inc(Z);
                       End
                    Else
                       Begin
                       {
                       { 16 Color 4 planes or KEEP FORMAT=FALSE