pcx.pas

TeeChart7Source 控件

       PcxBytesPerLine:=((MyWidth+7) Div 8);
       End;
     2:Begin
       PcxColorPlanes:=4;
       PcxBytesPerLine:=((MyWidth+7) Div 8);
       End;
     3:Begin
       PcxColorPlanes:=1;
       PcxBytesPerLine:=MyWidth;
       End;
     4:Begin
       PcxColorPlanes:=3;
       PcxBytesPerLine:=MyWidth;
       End;
     End;
B1:=PcxColorPlanes;
DoBlockWriteF(B1);
B1:=Lo(PcxBytesPerLine);
DoBlockWriteF(B1);
B1:=Hi(PcxBytesPerLine);
DoBlockWriteF(B1);
B1:=1;
DoBlockWriteF(B1);
B1:=0;
DoBlockWriteF(B1);
For X:=1 To 58 Do
    DoBlockWriteF(B1);
End;

(*
Procedure WritePcxLine(Var MyTempArray;Var Z:Word);
Var
  CurrentColorPlane,NumBytes,MaxX,W,X,Y:Integer;
  Ch,Dup:Byte;
Function MyGetByte(X:Word):Byte;
Var
  NewCh:Byte;
  Y:Integer;
Begin
Case MyPcxType Of
     1:Begin
       NewCh:=0;
       For Y:=7 DownTo 0 Do
           Begin
           NewCh:=NewCh Or ((DataLineArray(MyTempArray)[X] And 1) Shl Y);
           Inc(X);
           End;
       End;
     2:Begin
       {
       { Take 1st bit from next 8 bytes
       }
       NewCh:=0;
       For Y:=7-CurrentColorPlane DownTo 0-CurrentColorPlane Do
           Begin
           If Y<0 Then
              NewCh:=NewCh Or ((DataLineArray(MyTempArray)[X] And (1 Shl CurrentColorPlane)) Shr Abs(Y))
           Else
              NewCh:=NewCh Or ((DataLineArray(MyTempArray)[X] And (1 Shl CurrentColorPlane)) Shl Y);
           Inc(X);
           End;
       End;
     3:Begin
       NewCh:=DataLineArray(MyTempArray)[X];
       End;
     End;
MyGetByte:=NewCh;
End;

Begin
Case MyPcxType Of
     1:Begin
       W:=8;
       End;
     2:Begin
       W:=8;
       End;
     3:Begin
       W:=1;
       End;
     End;
MaxX:=PcxBytesPerLine*W;
Z:=0;
X:=0;
NumBytes:=0;
CurrentColorPlane:=0;
Repeat
    Begin
    {
    { Get whole BYTE!
    }
    {
    { Get runs!
    { Repeat
    { Until X=Width or DUP>63
    {
    }
    Dup:=1;
    While
          (X<Width-1)                   And
          (MyGetByte(X)=MyGetByte(X+W)) And
          (Dup<63)                      And
          (Dup+NumBytes<PcxBytesPerLine) Do
          Begin
          Inc(Dup);
          X:=X+W;
          End;
    Ch:=MyGetByte(X);
    If (Dup>1) Or (Ch>=$C0) Then
       Begin
       TempArrayDBIG[Z]:=$C0+Dup;
       Inc(Z);
       TempArrayDBIG[Z]:=Ch;
       Inc(Z);
       End
    Else
       Begin
       TempArrayDBIG[Z]:=Ch;
       Inc(Z);
       End;
    X:=X+W;
    NumBytes:=NumBytes+Dup;
    If X>=MaxX Then
       Begin
       Inc(CurrentColorPlane);
       X:=0;
       NumBytes:=0;
       End;
    End;
Until CurrentColorPlane>=PcxColorPlanes;
End;
*)

Procedure WritePcxLine(Var MyTempArray;Var ZZ:Word);
Label
  DOWP1,DOWP2,DOWP3,DOWPX,WPRLOOP1,WPWLOOP1,WPCONT1,
  DODUP,DOWPONE,DODUPEND,LJA,WPEX;
Var
  DUP,W,X,NumBytes,MaxX:Word;
  OldAX,FastAX:Word;
Function MyGetByte(X:Word):Byte;
Label
  DOMG1,DOMG2,DOMG3,DOMGX,LOOP1A,LOOP2A,L3B,L3X,IS8;
Var
  MyAX:Word;
Begin
        ASM
        PUSH    ESI
        MOV     EBX,0
        MOV     BX,AX
        CMP     LOCALPCXTYPE,1
        JZ      DOMG1
        CMP     LOCALPCXTYPE,2
        JZ      DOMG2
        CMP     LOCALPCXTYPE,3
        JZ      DOMG3
        CMP     LOCALPCXTYPE,4
        JZ      DOMG3
        JMP     DOMGX
DOMG1:
{
{ If we already are in 2 color mode, then just get the byte
}
        CMP     CURRBITSPERPIXEL,1
        JNZ     IS8
        SHR     EBX,3
        MOV     AL,[EDI+EBX]
        JMP     DOMGX
IS8:
        MOV     DX,8
        MOV     AL,0
LOOP1A:
        MOV     AH,[EDI+EBX]
        AND     AH,1
        MOV     CL,DL
        DEC     CL
        SHL     AH,CL
        OR      AL,AH
        INC     BX
        DEC     DX
        JNZ     LOOP1A
        JMP     DOMGX
DOMG2:
        MOV     DH,CURRENTCOLORPLANE
        MOV     DL,7
        SUB     DL,DH
        MOV     AL,0
LOOP2A:
        CMP     DL,0
        JGE     L3B
        MOV     AH,[EDI+EBX]
        MOV     CH,1
        MOV     CL,DH
        SHL     CH,CL
        AND     AH,CH

        MOV     CL,DL
        NEG     CL
        SHR     AH,CL
        OR      AL,AH
        JMP     L3X
L3B:
        MOV     AH,[EDI+EBX]
        MOV     CH,1
        MOV     CL,DH
        SHL     CH,CL
        AND     AH,CH

        MOV     CL,DL
        SHL     AH,CL
        OR      AL,AH
L3X:
        INC     BX
        DEC     DL
        MOV     CL,0
        SUB     CL,DH
        CMP     DL,CL                           {;AT BOTTOM YET?}
        JGE     LOOP2A
        JMP     DOMGX
DOMG3:
        MOV     AL,[EDI+EBX]
DOMGX:
        MOV     AH,0
        MOV     MYAX,AX
        POP     ESI
        END;
MyGetByte:=MyAX;
End;


Begin
LocalPCXType:=MyPcxType;
        ASM
        PUSHA
        PUSH    ESI
        PUSH    EDI
        MOV     EDI,MYTEMPARRAY;
        MOV     ESI,TEMPARRAYDBIG
        CMP     LOCALPCXTYPE,1
        JZ      DOWP1
        CMP     LOCALPCXTYPE,2
        JZ      DOWP2
        CMP     LOCALPCXTYPE,3
        JZ      DOWP3
        CMP     LOCALPCXTYPE,4
        JZ      DOWP3
        JMP     DOWPX
DOWP1:  MOV     W,8
        JMP     DOWPX
DOWP2:  MOV     W,8
        JMP     DOWPX
DOWP3:  MOV     W,1
DOWPX:
        MOV     AX,PCXBYTESPERLINE
        MOV     BX,W
        MUL     BX
        MOV     MAXX,AX
        MOV     EAX,ZZ
        MOV     WORD PTR [EAX],0
        MOV     X,0
        MOV     NUMBYTES,0
        MOV     CURRENTCOLORPLANE,0
WPRLOOP1:
        MOV     DUP,1
        MOV     AX,X
        PUSH    EBP
        CALL    MYGETBYTE
        POP     ECX
        MOV     FASTAX,AX
WPWLOOP1:
        MOV     AX,FASTAX
        MOV     OLDAX,AX
        PUSH    AX
        MOV     AX,X
        ADD     AX,W
        PUSH    EBP
        CALL    MYGETBYTE
        POP     ECX
        POP     BX
        MOV     FASTAX,BX
        CMP     AX,BX
        JNZ     WPCONT1
        MOV     AX,X
        INC     AX
        CMP     AX,MYWIDTH
        JGE     WPCONT1
        CMP     DUP,63
        JGE     WPCONT1
        MOV     AX,DUP
        ADD     AX,NUMBYTES
        CMP     AX,PCXBYTESPERLINE
        JGE     WPCONT1
        INC     DUP
        MOV     AX,W
        ADD     X,AX
        JMP     WPWLOOP1
WPCONT1:
        MOV     AX,OLDAX
        CMP     DUP,1
        JG      DODUP
        CMP     AL,0C0H
        JGE     DODUP
        JMP     DOWPONE
DODUP:
        MOV     ECX,ZZ
        MOVZX   EBX,WORD PTR [ECX]
        MOV     AH,0C0H
        OR      AH,BYTE PTR DUP
        MOV     [ESI+EBX],AH                   {;TEMPARRAYDBIG}
        MOV     ECX,ZZ
        INC     WORD PTR [ECX]
        MOV     [ESI+EBX+1],AL                 {;TEMPARRAYDBIG}
        MOV     ECX,ZZ
        INC     WORD PTR [ECX]
        JMP     DODUPEND
DOWPONE:
        MOV     ECX,ZZ
        MOVZX   EBX,WORD PTR [ECX]
        MOV     [ESI+EBX],AL                   {;TEMPARRAYDBIG}
        MOV     ECX,ZZ
        INC     WORD PTR [ECX]
DODUPEND:
        MOV     AX,W
        ADD     X,AX
        MOV     AX,DUP
        ADD     NUMBYTES,AX
        MOV     AX,X
        CMP     AX,MAXX
        JL      LJA
        INC     CURRENTCOLORPLANE
        MOV     X,0
        MOV     NUMBYTES,0
LJA:
        MOV     AL,CURRENTCOLORPLANE
        CMP     AL,PCXCOLORPLANES
        JGE     WPEX
        JMP     WPRLOOP1
WPEX:
        POP     EDI
        POP     ESI
        POPA
        END;
End;

Procedure PixelConvertRGBLines(Var TempArrayD,TempArrayDBIG2:DataLineArray);
Label
   PCRL_1,PCRL_24,PCRL_EXIT;
Begin
        ASM
        PUSHA
        PUSH    ESI
        PUSH    EDI
        MOVZX   ECX,MYWIDTH
        MOV     EDI,TEMPARRAYDBIG2
        MOV     ESI,TEMPARRAYD
        CMP     CURRBITSPERPIXEL,8
        JZ      PCRL_1
        CMP     CURRBITSPERPIXEL,24
        JZ      PCRL_24
PCRL_1:
        MOV     AH,0
        MOV     AL,[ESI]
{
{ GET PALETTE COLORS
}
        MOV     EBX,0
        MOVZX   EBX,AX
        SHL     EBX,1
        ADD     BX,AX
        MOV     AL,BYTE PTR PALETTEVGA[EBX+0]
        MOV     DL,BYTE PTR PALETTEVGA[EBX+1]
        MOV     DH,BYTE PTR PALETTEVGA[EBX+2]
        MOVZX   EBX,MYWIDTH
        SHL     AL,2
        SHL     DL,2
        SHL     DH,2
        MOV     [EDI],AL
        MOV     [EDI+EBX],DL
        SHL     EBX,1
        MOV     [EDI+EBX],DH
        INC     ESI
        INC     EDI
        LOOP    PCRL_1
        JMP     PCRL_EXIT
PCRL_24:
        MOV     AL,[ESI+2]
        MOV     DL,[ESI+1]
        MOV     DH,[ESI+0]
        MOVZX   EBX,MYWIDTH
        MOV     [EDI],AL
        MOV     [EDI+EBX],DL
        SHL     EBX,1
        MOV     [EDI+EBX],DH
        ADD     ESI,3
        INC     EDI
        LOOP    PCRL_24
        JMP     PCRL_EXIT
PCRL_EXIT:
        POP     EDI
        POP     ESI
        POPA
        END;
End;

Procedure WriteBody(Var ResultStatus:Boolean);
Var
  Z:Word;
  TmpPCXColorPlanes:Word;
  I:Integer;
Begin
TmpPCXColorPlanes:=PCXColorPlanes;
I:=0;
ResultStatus:=True;
Repeat
    Begin
    TempArrayD:=BitMap.ScanLine[I];
    {
    { Convert Any From
    }
    Case InPutBitsPerPixel Of
         1,4,8:Begin
               ConvertXBitsToYBits(TempArrayD^,TempArrayD2^,InputBitsPerPixel,8,MyWidth);
               CurrBitsPerPixel:=8;
               End;
            24:Begin
               ConvertXBitsToYBits(TempArrayD^,TempArrayD2^,InputBitsPerPixel,24,MyWidth);
               End;
         End;
    Case MyPcxType Of
         1..3:Begin
              WritePCXLine(TempArrayD2^,Z);
              IStream.Write(TempArrayDBIG^[0],Z);
              //BlockWrite(File1,TempArrayDBIG^[0],Z);
              End;
            4:Begin
              PCXColorPlanes:=1;
              {
              { Special Triple Plane Thingy :)
              }
              PixelConvertRGBLines(TempArrayD2^,TempArrayDBIG2^);
              WritePCXLine(TempArrayDBIG2^[0],Z);
              IStream.Write(TempArrayDBIG^[0],Z);
              //BlockWrite(File1,TempArrayDBIG^[0],Z);
              WritePCXLine(TempArrayDBIG2^[MyWidth],Z);
              IStream.Write(TempArrayDBIG^[0],Z);
              //BlockWrite(File1,TempArrayDBIG^[0],Z);
              WritePCXLine(TempArrayDBIG2^[MyWidth*2],Z);
              IStream.Write(TempArrayDBIG^[0],Z);
              //BlockWrite(File1,TempArrayDBIG^[0],Z);
              End;
            End;
    If IoResult<>0 Then
       ResultStatus:=False;
    Inc(I);
    End;
Until (I>=MyHeight) Or (ResultStatus=False);
PCXColorPlanes:=TmpPCXColorPlanes;
End;

Procedure Write256Palette;
Var
  X,Y:Word;
  B1:Byte;
Begin
For X:=0 To 255 Do
    Begin
    For Y:=1 To 3 Do
        Begin
        B1:=(PaletteVga[X,Y]*255) Div 63;
        DoBlockWriteF(B1);
        End;
    End;
End;

Begin
{
{ Write PCX File Write out either 2,16,256 colors
{
}
{$IFNDEF CLX}
SaveThePalette(BitMap.Palette,PaletteVGA);
{$ENDIF}
MyWidth:=BitMap.Width;
MyHeight:=BitMap.Height;
Case BitMap.PixelFormat Of
     pf1bit:CurrBitsPerPixel:=1;
     {$IFNDEF CLX}
     pf4bit:CurrBitsPerPixel:=4;
     {$ENDIF}
     pf8bit:CurrBitsPerPixel:=8;
     {$IFDEF CLX}
     pf32bit:CurrBitsPerPixel:=32;
     {$ELSE}
     pfDevice,
     pf24bit:CurrBitsPerPixel:=24;
     {$ENDIF}
     End;
InputBitsPerPixel:=CurrBitsPerPixel;
TempArrayDBIG:=Nil;
TempArrayDBIG2:=Nil;
GetMem(TempArrayDBig,MyWidth*4);
GetMem(TempArrayDBig2,MyWidth*4);
GetMem(TempArrayD2,MyWidth*4);
IStream:=Stream;
Stream.Position:=0;
WriteHeader;
WriteBody(ResultStatus);
If ResultStatus=False Then
   Begin
   {
   { Put ERROR handler here if you like!
   { ###ERROR###
   }
   Goto ErrExitClose;
   End;
B1:=$0C;
DoBlockWriteF(B1);
Write256Palette;
ErrExitClose:;
//Close(File1);
FreeMem(TempArrayD2,Width*4);
FreeMem(TempArrayDBig2,Width*4);
FreeMem(TempArrayDBig,Width*4);
End;

Begin
  WritePcxFile(Stream,PcxType);
End;

Procedure SaveToFileX(Const FileName:String; Const BitMap:TBitMap; PcxType:Byte);
var tmp : TMemoryStream;
begin
  tmp:=TMemoryStream.Create;
  try
    TeePCXToStream(tmp,Bitmap,PcxType);
    tmp.SaveToFile(FileName);
  finally
    tmp.Free;
  end;
end;

End.