dib.pas

传奇源代码的delphi版本

      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 compilation  }
  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
//    GlobalFree(THandle(FPBits));
  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 := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
                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
  TempImage: TDIBSharedImage;
begin
  if (FImage.RefCount > 1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.AllocHandle;
var
  TempImage: TDIBSharedImage;
begin
  if FImage.FMemoryImage then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, False);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.Compress;
var
  TempImage: TDIBSharedImage;
begin
  if (not FImage.FCompressed) and (BitCount in [4, 8]) then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Compress(FImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.Decompress;
var
  TempImage: TDIBSharedImage;
begin
  if FImage.FCompressed then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, FImage.FMemoryImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.FreeHandle;
var
  TempImage: TDIBSharedImage;
begin
  if not FImage.FMemoryImage then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Duplicate(FImage, True);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

type
  PRGBA = ^TRGBA;
  TRGBA = array[0..0] of Windows.TRGBQuad;

function TDIB.HasAlphaChannel: Boolean;
  {give that DIB contain the alphachannel}
var
  p: PRGBA;
  X, Y: Integer;
begin
  Result := True;
  if BitCount = 32 then
    for Y := 0 to Height - 1 do begin
      p := ScanLine[Y];
      for X := 0 to Width - 1 do begin
        if p[X].rgbReserved <> $0 then Exit;
      end
    end;
  Result := False;
end;

function TDIB.AssignAlphaChannel(DIB: TDIB): Boolean;
  {copy alphachannel from other DIB or add from DIB8}
var
  p0, p1: PRGBA;
  pB: PArrayByte;
  X, Y: Integer;
  tmpDIB: TDIB;
begin
  Result := False;
  if GetEmpty then Exit;
  {Alphachannel can be copy into 32bit DIB only!}
  if BitCount <> 32 then begin
    tmpDIB := TDIB.Create;
    try
      tmpDIB.Assign(Self);
      Clear;
      SetSize(tmpDIB.Width, tmpDIB.Height, 32); //1.07f
      Canvas.Draw(0, 0, tmpDIB);
    finally
      tmpDIB.Free;
    end;
  end;
  {Must be the same size!}
  if not ((Width = DIB.Width) and (Height = DIB.Height)) then Exit;
  case DIB.BitCount of
    32: begin
        for Y := 0 to Height - 1 do begin
          p0 := ScanLine[Y];
          p1 := DIB.ScanLine[Y];
          for X := 0 to Width - 1 do begin
            p0[X].rgbReserved := p1[X].rgbReserved;
          end
        end;
      end;
    8: begin
        for Y := 0 to Height - 1 do begin
          p0 := ScanLine[Y];
          pB := DIB.ScanLine[Y];
          for X := 0 to Width - 1 do begin
            p0[X].rgbReserved := pB[X];
          end
        end;
      end;
  else
    Exit;
  end;
  Result := True;
end;

procedure TDIB.RetAlphaChannel(out DIB: TDIB);
  {Store alphachannel information into DIB8}
var
  p0: PRGBA;
  pB: PArrayByte;
  X, Y: Integer;
begin
  DIB := nil;
  if not HasAlphaChannel then exit;
  DIB := TDIB.Create;
  DIB.SetSize(Width, Height, 8);
  for Y := 0 to Height - 1 do begin
    p0 := ScanLine[Y];
    pB := DIB.ScanLine[Y];
    for X := 0 to Width - 1 do begin
      pB[X] := p0[X].rgbReserved;
    end
  end;
end;

function TDIB.GetBitmapInfo: PBitmapInfo;
begin
  Result := FImage.FBitmapInfo;
end;

function TDIB.GetBitmapInfoSize: Integer;
begin
  Result := FImage.FBitmapInfoSize;
end;