dib.pas

传奇服务端Delphi7编译必需的全部第三方控件！！！！！

    case FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: EncodeRLE4;
      BI_RLE8: EncodeRLE8;
    else
      Duplicate(Source, Source.FMemoryImage);
    end;
  end;
end;

procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);

  procedure DecodeRLE4;
  var
    B1, B2, C: Byte;
    Dest, Src, P: PByte;
    X, Y, i: Integer;
  begin
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1=0 then
      begin
        case B2 of
          0: begin  {  End of line  }
               X := 0;
               Inc(Y);
             end;
          1: Break; {  End of bitmap  }
          2: begin  {  Difference of coordinates  }
               Inc(X, B1);
               Inc(Y, B2); Inc(Src, 2);
             end;
        else
          {  Absolute mode  }
          Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);

          C := 0;
          for i:=0 to B2-1 do
          begin
            if i and 1=0 then
            begin
              C := Src^; Inc(Src);
            end else
            begin
              C := C shl 4;
            end;

            P := Pointer(Integer(Dest)+X shr 1);
            if X and 1=0 then
              P^ := (P^ and $0F) or (C and $F0)
            else
              P^ := (P^ and $F0) or ((C and $F0) shr 4);

            Inc(X);
          end;
        end;
      end else
      begin
        {  Encoding mode  }
        Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);

        for i:=0 to B1-1 do
        begin
          P := Pointer(Integer(Dest)+X shr 1);
          if X and 1=0 then
            P^ := (P^ and $0F) or (B2 and $F0)
          else
            P^ := (P^ and $F0) or ((B2 and $F0) shr 4);

          Inc(X);

          // Swap nibble
          B2 := (B2 shr 4) or (B2 shl 4);
        end;
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

  procedure DecodeRLE8;
  var
    B1, B2: Byte;
    Dest, Src: PByte;
    X, Y: Integer;
  begin
    Dest := FPBits;
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1=0 then
      begin
        case B2 of
          0: begin  {  End of line  }
               X := 0; Inc(Y);
               Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
             end;
          1: Break; {  End of bitmap  }
          2: begin  {  Difference of coordinates  }
               Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
               Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
             end;
        else
          {  Absolute mode  }
          Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
        end;
      end else
      begin
        {  Encoding mode  }
        FillChar(Dest^, B1, B2); Inc(Dest, B1);
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

begin
  if not Source.FCompressed then
    Duplicate(Source, MemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
    case Source.FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: DecodeRLE4;
      BI_RLE8: DecodeRLE8;
    else
      Duplicate(Source, MemoryImage);
    end;                                               
  end;
end;

procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
var
  BI: TBitmapInfoHeader;
  BC: TBitmapCoreHeader;
  BCRGB: array[0..255] of TRGBTriple;

  procedure LoadRLE4;
  begin
    FSize := BI.biSizeImage;
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRLE8;
  begin
    FSize := BI.biSizeImage;
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRGB;
  var
    y: Integer;
  begin
    if BI.biHeight<0 then
    begin
      for y:=0 to Abs(BI.biHeight)-1 do
        Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
    end else
    begin
      Stream.ReadBuffer(FPBits^, FSize);
    end;
  end;

var
  i, PalCount: Integer;
  OS2: Boolean;
  Localpf: TLocalDIBPixelFormat;
  AColorTable: TRGBQuads;
  APixelFormat: TDIBPixelFormat;
begin
  {  Header size reading  }
  i := Stream.Read(BI.biSize, 4);

  if i=0 then
  begin
    Create;
    Exit;
  end;
  if i<>4 then
    raise EInvalidGraphic.Create(SInvalidDIB);

  {  Kind check of DIB  }
  OS2 := False;

  case BI.biSize of
    SizeOf(TBitmapCoreHeader):
      begin
        {  OS/2 type  }
        Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4);

        with BI do
        begin
          biClrUsed := 0;
          biCompression := BI_RGB;
          biBitCount := BC.bcBitCount;
          biHeight := BC.bcHeight;
          biWidth := BC.bcWidth;
        end;

        OS2 := True;
      end;
    SizeOf(TBitmapInfoHeader):
      begin
        {  Windows type  }
        Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4);
      end;
  else
    raise EInvalidGraphic.Create(SInvalidDIB);
  end;

  {  Bit mask reading.  }
  if BI.biCompression = BI_BITFIELDS then
  begin
    Stream.ReadBuffer(Localpf, SizeOf(Localpf));
    with Localpf do
      APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
  end else
  begin
    if BI.biBitCount=16 then
      APixelFormat := MakeDIBPixelFormat(5, 5, 5)
    else if BI.biBitCount=32 then
      APixelFormat := MakeDIBPixelFormat(8, 8, 8)
    else
      APixelFormat := MakeDIBPixelFormat(8, 8, 8);
  end;

    {  Palette reading  }
  PalCount := BI.biClrUsed;
  if (PalCount=0) and (BI.biBitCount<=8) then
    PalCount := 1 shl BI.biBitCount;
  if PalCount>256 then PalCount := 256;

  FillChar(AColorTable, SizeOf(AColorTable), 0);

  if OS2 then
  begin
    {  OS/2 type  }
    Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple)*PalCount);
    for i:=0 to PalCount-1 do
    begin
      with BCRGB[i] do
        AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
    end;
  end else
  begin
    {  Windows type  }
    Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
  end;

  {  DIB 嶌惉  }
  NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
    MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);

  {  Pixel data reading  }
  case BI.biCompression of
    BI_RGB      : LoadRGB;
    BI_RLE4     : LoadRLE4;
    BI_RLE8     : LoadRLE8;
    BI_BITFIELDS: LoadRGB;
  else
    raise EInvalidGraphic.Create(SInvalidDIB);
  end;
end;

destructor TDIBSharedImage.Destroy;
begin
  if FHandle<>0 then
  begin
    if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
    DeleteObject(FHandle);
  end else
  begin
    if FPBits<>nil then
      GlobalFreePtr(FPBits);
  end;

  PaletteManager.DeletePalette(FPalette);
  if FDC<>0 then DeleteDC(FDC);

  FreeMem(FBitmapInfo);
  inherited Destroy;
end;

procedure TDIBSharedImage.FreeHandle;
begin
end;

function TDIBSharedImage.GetPalette: THandle;
begin
  if FPaletteCount>0 then
  begin
    if FChangePalette then
    begin
      FChangePalette := False;
      PaletteManager.DeletePalette(FPalette);
      FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount);
    end;
    Result := FPalette;
  end else
    Result := 0;
end;

procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads);
begin
  FColorTable := Value;
  FChangePalette := True;

  if (FSize>0) and (FPaletteCount>0) then
  begin
    SetDIBColorTable(FDC, 0, 256, FColorTable);
    Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
  end;
end;

{ TDIB }

var
  FEmptyDIBImage: TDIBSharedImage;

function EmptyDIBImage: TDIBSharedImage;
begin
  if FEmptyDIBImage=nil then
  begin
    FEmptyDIBImage := TDIBSharedImage.Create;
    FEmptyDIBImage.Reference;
  end;
  Result := FEmptyDIBImage;
end;

constructor TDIB.Create;
begin
  inherited Create;
  SetImage(EmptyDIBImage);
end;

destructor TDIB.Destroy;
begin
  SetImage(EmptyDIBImage);
  FCanvas.Free;
  inherited Destroy;
end;

procedure TDIB.Assign(Source: TPersistent);

  procedure AssignBitmap(Source: TBitmap);
  var
    Data: array[0..1023] of Byte;
    BitmapRec: Windows.PBitmap;
    DIBSectionRec: PDIBSection;
    PaletteEntries: TPaletteEntries;
  begin
    GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries);
    ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
    UpdatePalette;

    case GetObject(Source.Handle, SizeOf(Data), @Data) of
      SizeOf(Windows.TBitmap):
          begin
            BitmapRec := @Data;
            case BitmapRec^.bmBitsPixel of
              16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
            else
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end;
            SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
          end;
      SizeOf(TDIBSection):
          begin
            DIBSectionRec := @Data;
            if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
            begin
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end else
            if DIBSectionRec^.dsBm.bmBitsPixel>8 then
            begin
              PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
                DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
            end else
            begin
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end;
            SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
              DIBSectionRec^.dsBm.bmBitsPixel);
          end;
    else
      Exit;
    end;

    FillChar(PBits^, Size, 0);
    Canvas.Draw(0, 0, Source);
  end;

  procedure AssignGraphic(Source: TGraphic);
  begin
    if Source is TBitmap then
      AssignBitmap(TBitmap(Source))
    else
    begin
      SetSize(Source.Width, Source.Height, 24);
      FillChar(PBits^, Size, 0);
      Canvas.Draw(0, 0, Source);
    end;
  end;

begin
  if Source=nil then
  begin
    Clear;
  end else if Source is TDIB then
  begin
    if Source<>Self then
      SetImage(TDIB(Source).FImage);
  end else if Source is TGraphic then
  begin
    AssignGraphic(TGraphic(Source));
  end else if Source is TPicture then
  begin
    if TPicture(Source).Graphic<>nil then
      AssignGraphic(TPicture(Source).Graphic)
    else
      Clear;
  end else 
    inherited Assign(Source);
end;

procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  OldPalette: HPalette;
  OldMode: Integer;
begin
  if Size>0 then
  begin
    if PaletteCount>0 then
    begin
      OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
      RealizePalette(ACanvas.Handle);
    end else
      OldPalette := 0;
    try
      OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
      try
        GdiFlush;
        if FImage.FMemoryImage then
        begin
          with Rect do
            StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
              0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
        end else
        begin
          with Rect do
            StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
              FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
        end;
      finally
        SetStretchBltMode(ACanvas.Handle, OldMode);
      end;
    finally
      SelectPalette(ACanvas.Handle, OldPalette, False);
    end;
  end;
end;

procedure TDIB.Clear;
begin
  SetImage(EmptyDIBImage);
end;

procedure TDIB.CanvasChanging(Sender: TObject);
begin
  Changing(False);
end;

procedure TDIB.Changing(MemoryImage: Boolean);
var