⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 pcx.pas

📁 TeeChart7Source 控件
💻 PAS
📖 第 1 页 / 共 3 页
字号:
🔍
123 
                       }
                       For CX:=7 DownTo 0 Do
                          Begin
                          TmpB1:=0;
                          If C And (1 Shl CX) <>0 Then
                             TmpB1:=1;
                          TmpB1:=TmpB1 Shl CurrentPlane;
                          TempArrayDBIG[Z]:=TempArrayDBIG[Z]+TmpB1;
                          Inc(Z);
                          If Z>=RealWidth Then
                             Begin
                             Z:=0;
                             Inc(CurrentPlane);
                             End;
                          End;
                       End;
                    End;
                  8:Begin
                    TempArrayDBIG[Z]:=C;
                    Inc(Z);
                    End;
                End;
             Dec(I);
             Inc(N);
             End;
       End
    Else
       Begin
       Case BitsPerPixel Of
            1:Begin
              If (MyKeepTrueFormat=True) And (PcxColorPlanes=1) Then
                 Begin
                 TempArrayDBIG[Z]:=TempArrayDBIG[Z]+B1;
                 Inc(Z);
                 End
              Else
                 Begin
                 For CX:=7 DownTo 0 Do
                  Begin
                  TmpB1:=0;
                  If B1 And (1 Shl CX) <>0 Then
                     TmpB1:=1;
                  TmpB1:=TmpB1 Shl CurrentPlane;
                  TempArrayDBIG[Z]:=TempArrayDBIG[Z]+TmpB1;
                  Inc(Z);
                  If Z>=RealWidth Then
                     Begin
                     Z:=0;
                     Inc(CurrentPlane);
                     End;
                  End;
                 End;
              End;
            8:Begin
              TempArrayDBIG[Z]:=B1;
              Inc(Z);
              End;
            End;
       Inc(N);
       End;
    End;
Until N>=MaximumN;
End;

Procedure ReadPcxHeader(Var FileOk:Boolean; Var ErrorString:ShortString);
Label
  ExitIt;
Var
  B1:Byte;
  B2,X:Word;
  TopOfs,LeftOfs:Word;
Begin
B1:=FastGetByte;
If B1<>10 Then
   Begin
   ErrorString:='Not a PCX file, or header read error.';
   FileOk:=False;
   Goto ExitIt;
   End;
PcxVersion:=FastGetByte;
PcxEncoding:=FastGetByte;
BitsPerPixel:=FastGetByte;
LeftOfs:=FastGetWord;
TopOfs:=FastGetWord;
Width:=FastGetWord;
Height:=FastGetWord;
Width:=Width-LeftOfs+1;
Height:=Height-TopOfs+1;
FastGetWord;
FastGetWord;
B2:=BitsPerPixel;
BitsPerPixel:=4;
SetupMaskAndColorMap;
BitsPerPixel:=B2;
FastGetByte;
PcxColorPlanes:=FastGetByte;
PcxBytesPerLine:=FastGetWord;
PcxPaletteType:=FastGetWord;
For X:=1 To 58 Do
   FastGetByte;
If NOT(BitsPerPixel In [1,4,8,16,24,32]) Then
   Begin
   FileOk:=False;
   ErrorString:='Not a valid PCX file!';
   End;
ExitIt:;

End;

Procedure LoadFromFileX;
Var
  B1:Byte;
  I:Integer;
  NewWidth:Word;
  L1,L2:LongInt;
  PaletteOk:Boolean;
  FileOk:Boolean;
  Ptr1:Pointer;
Procedure UpDatePalette;
Var
  I:Integer;
begin
For I:=0 To 255 Do
    Syspal.LPal.PalPalEntry[I].peflags:=0;
   Case BitsPerPixel Of
        1:Begin
          If PcxColorPlanes=1 Then
             Begin
             If MyKeepTrueFormat Then
                BitMap.PixelFormat:=pf1bit
             Else
                Begin
                Case MyKeepTrueBits Of
                     8: BitMap.PixelFormat:=pf8bit;
                    {$IFDEF CLX}
                    32: BitMap.PixelFormat:=pf32bit;
                    {$ELSE}
                    24: BitMap.PixelFormat:=pf24bit;
                    {$ENDIF}
                    End;
                End;
             MakePalBW(BitMap);
             End
          Else
             Begin
               {$IFNDEF CLX}
               BitMap.IgnorePalette:=False;
               SysPal.LPal.palVersion:=$300;
               SysPal.LPal.palNumEntries:=17;
               For I:=0 To 16 Do
                   Begin
                   Syspal.LPal.PalPalEntry[I].peRed:=  (PaletteVga[I,1]+1)*4-1;
                   Syspal.LPal.PalPalEntry[I].peGreen:=(PaletteVga[I,2]+1)*4-1;
                   Syspal.LPal.PalPalEntry[I].peBlue:= (PaletteVga[I,3]+1)*4-1;
                   End;
               If MyKeepTrueFormat Then
                  BitMap.PixelFormat:=pf8bit
               Else
                  Begin
                  Case MyKeepTrueBits Of
                       8:BitMap.PixelFormat:=pf8bit;
                      24:BitMap.PixelFormat:=pf24bit;
                      End;
                  End;
               Bitmap.Palette:= CreatePalette(Syspal.LPal);
               {$ENDIF}
             End;
          End;
        8:Begin
          If PcxColorPlanes=1 Then
             Begin
             If MyKeepTrueFormat Then
                BitMap.PixelFormat:=pf8bit
             Else
                Begin
                Case MyKeepTrueBits Of
                     8: BitMap.PixelFormat:=pf8bit;
                    {$IFDEF CLX}
                    32: BitMap.PixelFormat:=pf32bit;
                    {$ELSE}
                    24: BitMap.PixelFormat:=pf24bit;
                    {$ENDIF}
                    End;
                End;
             MakePalPalette(BitMap);
             End
          Else
             Begin
             If MyKeepTrueFormat=True Then
                Begin
                {$IFDEF CLX}
                BitMap.PixelFormat:=pf32bit;
                {$ELSE}
                BitMap.PixelFormat:=pf24bit;
                {$ENDIF}
                MakeGenPalette;
                End
             Else
                Begin
                  Case MyKeepTrueBits Of
                     8:Begin
                       BitMap.PixelFormat:=pf8bit;
                       SetUpMaskGrayPalette
                       End;
                    {$IFDEF CLX}
                    32:Begin
                       BitMap.PixelFormat:=pf32bit;
                       MakeGenPalette;
                       End;
                    {$ELSE}
                    24:Begin
                       BitMap.PixelFormat:=pf24bit;
                       MakeGenPalette;
                       End;
                    {$ENDIF}
                  End;

                  {$IFNDEF CLX}
                  BitMap.IgnorePalette:=True;
                  {$ENDIF}
                End;

             MakePalPalette(BitMap);
             End;
          End;
        End;
End;

Procedure Do8;
Var
  J:Word;
Begin
For J:=0 To Width-1 Do
    Begin
    TempArrayDBIG^[J]:=PCXGrayValue(
                       TempArrayDBIG^[J],
                       TempArrayDBIG^[PcxBytesPerLine+J],
                       TempArrayDBIG^[(PcxBytesPerLine Shl 1)+J]);
    End;
End;
Procedure Do24;
Var
  J,Z0,Z1,Z2,Z3:Word;
Begin
Z0:=0;
Z1:=0;
Z2:=PcxBytesPerLine;
Z3:=Z2+Z2;
For J:=0 To Width-1 Do
    Begin
    TempArrayDBIG16^[Z0+0]:=TempArrayDBIG^[Z3];
    TempArrayDBIG16^[Z0+1]:=TempArrayDBIG^[Z2];
    TempArrayDBIG16^[Z0+2]:=TempArrayDBIG^[Z1];
    Z0:=Z0+Global_HiColor;
    Inc(Z1);
    Inc(Z2);
    Inc(Z3);
    End;
Move(TempArrayDBIG16^,TempArrayDBIG^,NewWidth);
End;

Procedure Do8Adjust;
Begin
Move(TempArrayDBIG^,Ptr1^,Width);
End;

Procedure Do24Adjust;
Var
  X,Z:Word;
  B1:Byte;
Begin
Z:=0;
For X:=0 To Width-1 Do
    Begin
    B1:=TempArrayDBIG^[X];
    DataLineArray(Ptr1^)[Z+0]:=PaletteVGA[B1,3]*4+3;
    DataLineArray(Ptr1^)[Z+1]:=PaletteVGA[B1,2]*4+3;
    DataLineArray(Ptr1^)[Z+2]:=PaletteVGA[B1,1]*4+3;
    Z:=Z+Global_HiColor;
    End;
End;

Begin
MyKeepTrueFormat:=ShouldIKeepTrueFormat(MyKeepTrueBits);
ErrorString:='';
FileOk:=True;
OpenFile(FileName,FileOk);
ReadPcxHeader(FileOK,ErrorString);
If FileOk Then
   Begin
   BitMap.Height:=1;
   BitMap.Width:=1;
   BitMap.Height:=Height;
   BitMap.Width:=Width;
   UpdatePalette;
   {
   { Check version number for FAKE palette!
   }
   NewWidth:=Width*Global_HiColor;
   TempArrayDBIG:=Nil;
   TempArrayDBIG16:=Nil;
   GetMem(TempArrayDBig,Width*4+20{Slack Bytes});
   GetMem(TempArrayDBig16,NewWidth+20);
   PaletteOk:=True;
   If PcxVersion=3 Then
      Begin
      PaletteDefaults;
      End;
   If (BitsPerPixel=1) And (PcxColorPlanes=1) Then
      Begin
      PaletteVGA[0,1]:=0;
      PaletteVGA[0,2]:=0;
      PaletteVGA[0,3]:=0;
      PaletteVGA[1,1]:=63;
      PaletteVGA[1,2]:=63;
      PaletteVGA[1,3]:=63;
      End;
   If (BitsPerPixel=8) And (PcxColorPlanes=1) Then
      Begin
      {
      { Fast PALETTE Read On Picture (Could be wrong!)
      }
      L1:=FilePos(PictureFile);
      If SizeOf(IndexData)>L1 Then
         L1:=SizeOf(IndexData);
      L2:=L1-Index1;
      Seek(PictureFile,FileSize(PictureFile));
      L1:=FilePos(PictureFile);
      L1:=L1-(3*256+1);
      Seek(PictureFile,L1);
      FileIoReset;
   {
   { Reset GetByte Stuff!
   }
      B1:=FastGetByte;
      If B1<>$0C Then
         PaletteOk:=False;
      SetupMaskAndColorMap;
      Seek(PictureFile,L2);
      FileIoReset;
      End;
   If (BitsPerPixel=8) And (PcxColorPlanes=3) Then
      SetupMaskGrayPalette;
   I:=0;
   UpDatePalette;
   Repeat
    Begin
    If BitsPerPixel<>8 Then
       Begin
       FillerUp(TempArrayDBIG^[0],Width*PcxColorPlanes+20{Slack Bytes},0);
       End;
    ReadPCXLine;
    If (PCXColorPlanes=3) And
       (BitsPerPixel=8)   Then
       Begin
       {
       { 24 Bit Image!
       }
       If MyKeepTrueFormat Then
          Do24
       Else
          Begin
          Case MyKeepTrueBits Of
               8:Do8;
              24:Do24;
              End;
          End;
       End
    Else
       Begin
       {
       { 1,4 or 8 Bit file!
       }
       End;
    {
    { Put line into memory!
    }
    Ptr1:=BitMap.ScanLine[I];
    Case BitsPerPixel Of
         1:Begin
           If (MyKeepTrueFormat) And (PcxColorPlanes=1) Then
              Begin
              {
              { B&W Keep It
              }
              Move(TempArrayDBIG^,Ptr1^,PcxBytesPerLine*PcxColorPlanes)
              End
           Else
              Begin
              {
              { No KEEP or 16 Color
              }
              If MyKeepTrueFormat Then
                 Do8Adjust
              Else
                 Begin
                 Case MyKeepTrueBits Of
                      8:Do8Adjust;
                     24:Do24Adjust;
                     End;
                 End;
              End;
           End;
         8:Begin
           If PcxColorPlanes=1 Then
              Begin
              If MyKeepTrueFormat=True Then
                 Move(TempArrayDBIG^,Ptr1^,PcxBytesPerLine*PcxColorPlanes)
              Else
                 Begin
                 Case MyKeepTrueBits Of
                      8:Move(TempArrayDBIG^,Ptr1^,PcxBytesPerLine);
                     24:Do24Adjust;
                     End;
                 End;
              End
           Else
              Begin
              {
              { 24 bit file
              }
              If MyKeepTrueFormat Then
                 Move(TempArrayDBIG^,Ptr1^,PcxBytesPerLine*PcxColorPlanes)
              Else
                 Begin
                 Case MyKeepTrueBits Of
                      8:Move(TempArrayDBIG^,Ptr1^,Width);
                     24:Move(TempArrayDBIG^,Ptr1^,PcxBytesPerLine*PcxColorPlanes);
                     End;
                 End;
              End;
           End;
         End;
    Inc(I);
    End;
   Until I>=Height;
   {
   { Now read in REAL Palette!
   }
   If (BitsPerPixel=8) And (PcxColorPlanes=1) Then
      Begin
      If PaletteOk=False Then
         Begin
         FastGetByte;
         SetupMaskAndColorMap;
         End;
      End;
   If (BitsPerPixel=8) And (PcxColorPlanes=3) Then
      BitsPerPixel:=24;
   If (BitsPerPixel=1) And (PcxColorPlanes=4) Then
      BitsPerPixel:=4;
   FreeMem(TempArrayDBig16,NewWidth+20);
   FreeMem(TempArrayDBig,Width*4+20{Slack Bytes});
   If IoResult<>0 Then ;
   Close(PictureFile);
   End;
If IoResult<>0 Then ;
End;

Var
  TempArrayDBig2:^DataLineArray; {0-MaxWidth*4}
Var
  LocalPCXType:Word;
  CurrentColorPlane:Byte;
  MyWidth,MyHeight:Word;
  CurrBitsPerPixel:Word;
  InputBitsPerPixel:Word;
  IStream:TStream;

Procedure TeePCXToStream(Stream:TStream; Const BitMap:TBitMap; PcxType:Byte);
Procedure WritePcxFile(Stream:TStream; MyPcxType:Byte);
Label
  ErrExitClose;
Var
//  File1:File;
  B1:Byte;
  ResultStatus:Boolean;

Procedure DoBlockWriteF(Var B1:Byte);
Begin
  IStream.Write(B1,1);
//BlockWrite(File1,B1,1);
End;

Procedure WriteHeader;
Var
  B1,B2:Byte;
  MyTopOfs,MyLeftOfs:Integer;
  X,Y:Word;
Begin
B1:=10;
DoBlockWriteF(B1);
B1:=5;
DoBlockWriteF(B1);
B1:=1;
DoBlockWriteF(B1);
Case MyPcxType Of
     1:B1:=1;
     2:B1:=1;
     3:B1:=8;
     4:B1:=8;
     End;
DoBlockWriteF(B1);
MyLeftOfs:=0;
MyTopOfs:=0;
B1:=Lo(MyLeftOfs);
DoBlockWriteF(B1);
B2:=Hi(MyLeftOfs);
DoBlockWriteF(B2);
B1:=Lo(MyTopOfs);
DoBlockWriteF(B1);
B2:=Hi(MyTopOfs);
DoBlockWriteF(B2);
B1:=Lo(MyLeftOfs+MyWidth-1);
DoBlockWriteF(B1);
B2:=Hi(MyLeftOfs+MyWidth-1);
DoBlockWriteF(B2);
B1:=Lo(MyTopOfs+MyHeight-1);
DoBlockWriteF(B1);
B2:=Hi(MyTopOfs+MyHeight-1);
DoBlockWriteF(B2);

B1:=Lo(MyWidth);
DoBlockWriteF(B1);
B2:=Hi(MyWidth);
DoBlockWriteF(B2);
B1:=Lo(MyHeight);
DoBlockWriteF(B1);
B2:=Hi(MyHeight);
DoBlockWriteF(B2);
{
{ Write Palette
}
For X:=0 To 15 Do
    Begin
    For Y:=1 To 3 Do
        Begin
        B1:=(PaletteVga[X,Y]*255) Div 63;
        DoBlockWriteF(B1);
        End;
    End;
B1:=0;
DoBlockWriteF(B1);
Case MyPcxType Of
     1:Begin
       PcxColorPlanes:=1;
123

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -