dib.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

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(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
  {copy alphachannel from other DIB or add from DIB8}
var
  p32_0, p32_1: PRGBA;
  p24: Pointer;
  pB: PArrayByte;
  X, Y: Integer;
  tmpDIB, qAlpha: 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);
      Canvas.Draw(0, 0, tmpDIB);
    finally
      tmpDIB.Free;
    end;
  end;
  qAlpha := TDIB.Create;
  try
    if ForceResize then
    begin
      {create temp}
      tmpDIB := TDIB.Create;
      try
        {picture}
        tmpDIB.Assign(ALPHA);
        {resample size}
        tmpDIB.DoResample(Width, Height, ftrBSpline);
        {convert to greyscale}
        tmpDIB.Greyscale(8);
        {return picture to qAlpha}
        qAlpha.Assign(tmpDIB);
      finally
        tmpDIB.Free;
      end;
    end
    else
      {Must be the same size!}
      if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
      else qAlpha.Assign(ALPHA);
    {It works now with qAlpha only}
    case qAlpha.BitCount of
      24: begin
          for Y := 0 to Height - 1 do begin
            p32_0 := ScanLine[Y];
            p24 := qAlpha.ScanLine[Y];
            for X := 0 to Width - 1 do with PBGR(p24)^ do begin
                p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
              end
          end;
        end;
      32: begin
          for Y := 0 to Height - 1 do begin
            p32_0 := ScanLine[Y];
            p32_1 := qAlpha.ScanLine[Y];
            for X := 0 to Width - 1 do begin
              p32_0[X].rgbReserved := p32_1[X].rgbReserved;
            end
          end;
        end;
      8: begin
          for Y := 0 to Height - 1 do begin
            p32_0 := ScanLine[Y];
            pB := qAlpha.ScanLine[Y];
            for X := 0 to Width - 1 do begin
              p32_0[X].rgbReserved := pB[X];
            end
          end;
        end;
      1: begin
          for Y := 0 to Height - 1 do begin
            p32_0 := ScanLine[Y];
            pB := qAlpha.ScanLine[Y];
            for X := 0 to Width - 1 do begin
              if pB[X] = 0 then
                p32_0[X].rgbReserved := $FF
              else
                p32_0[X].rgbReserved := 0
            end
          end;
        end;
    else
      Exit;
    end;
    Result := True;
  finally
    qAlpha.Free;
  end;
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;

function TDIB.GetCanvas: TCanvas;
begin
  if (FCanvas = nil) or (FCanvas.Handle = 0) then
  begin
    AllocHandle;

    FCanvas := TCanvas.Create;
    FCanvas.Handle := FImage.FDC;
    FCanvas.OnChanging := CanvasChanging;
  end;
  Result := FCanvas;
end;

function TDIB.GetEmpty: Boolean;
begin
  Result := Size = 0;
end;

function TDIB.GetHandle: THandle;
begin
  Changing(True);
  Result := FImage.FHandle;
end;

function TDIB.GetHeight: Integer;
begin
  Result := FHeight;
end;

function TDIB.GetPalette: HPalette;
begin
  Result := FImage.GetPalette;
end;

function TDIB.GetPaletteCount: Integer;
begin
  Result := FImage.FPaletteCount;
end;

function TDIB.GetPBits: Pointer;
begin
  Changing(True);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FPBits;
end;

function TDIB.GetPBitsReadOnly: Pointer;
begin
  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FPBits;
end;

function TDIB.GetScanLine(Y: Integer): Pointer;
begin
  Changing(True);
  if (Y < 0) or (Y >= FHeight) then
    raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
end;

function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
begin
  if (Y < 0) or (Y >= FHeight) then
    raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
end;

function TDIB.GetTopPBits: Pointer;
begin
  Changing(True);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FTopPBits;
end;

function TDIB.GetTopPBitsReadOnly: Pointer;
begin
  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FTopPBits;
end;

function TDIB.GetWidth: Integer;
begin
  Result := FWidth;
end;

const
  Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01);
  Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF,
    $FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE);
  Mask4: array[0..1] of DWORD = ($F0, $0F);
  Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0);

  Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0);
  Shift4: array[0..1] of DWORD = (4, 0);

function TDIB.GetPixel(X, Y: Integer): DWORD;
begin
  Decompress;

  Result := 0;
  if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
  begin
    case FBitCount of
      1: Result := (PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
      4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
      8: Result := PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X];
      16: Result := PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X];
      24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
          Result := R or (G shl 8) or (B shl 16);
      32: Result := PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X];
    end;
  end;
end;

procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
var
  P: PByte;
begin
  Changing(True);

  if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
  begin
    case FBitCount of
      1: begin
          P := @PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3];
          P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
        end;
      4: begin
          P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
          P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
        end;
      8: PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
      16: PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
      24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
        begin
          B := Byte(Value shr 16);
          G := Byte(Value shr 8);
          R := Byte(Value);
        end;
      32: PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
    end;
  end;
end;

procedure TDIB.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  {  For interchangeability with an old version.  }
  Filer.DefineBinaryProperty('DIB', LoadFromStream, nil, False);
end;

type
  TGlobalMemoryStream = class(TMemoryStream)
  private
    FHandle: THandle;
  public
    constructor Create(AHandle: THandle);
    destructor Destroy; override;
  end;

constructor TGlobalMemoryStream.Create(AHandle: THandle);
begin
  inherited Create;
  FHandle := AHandle;
  SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
end;

destructor TGlobalMemoryStream.Destroy;
begin
  GlobalUnLock(FHandle);
  SetPointer(nil, 0);
  inherited Destroy;
end;

procedure TDIB.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  Stream: TGlobalMemoryStream;
begin
  Stream := TGlobalMemoryStream.Create(AData);
  try
    ReadData(Stream);
  finally
    Stream.Free;
  end;
end;

const
  BitmapFileType = Ord('B') + Ord('M') * $100;

procedure TDIB.LoadFromStream(Stream: TStream);
var
  BF: TBitmapFileHeader;
  i: Integer;
  ImageJPEG: TJPEGImage;
begin
  {  File header reading  }
  i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
  if i = 0 then Exit;
  if i <> SizeOf(TBitmapFileHeader) then
    raise EInvalidGraphic.Create(SInvalidDIB);

  {  Is the head jpeg ?}

  if BF.bfType = $D8FF then begin
    ImageJPEG := TJPEGImage.Create;
    try
      try
        Stream.Position := 0;
        ImageJPEG.LoadFromStream(Stream);
      except
        on EInvalidGraphic do ImageJPEG := nil;
      end;
      if ImageJPEG <> nil then
      begin
        {set size and bitcount in natural units of jpeg}
        SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
        Canvas.Draw(0, 0, ImageJPEG);
        Exit
      end;
    finally
      ImageJPEG.Free;
    end;
  end
  else
  {  Is the head 'BM'?  }
    if BF.bfType <> BitmapFileType then
      raise EInvalidGraphic.Create(SInvalidDIB);

  ReadData(Stream);
end;

procedure TDIB.ReadData(Stream: TStream);
var
  TempImage: TDIBSharedImage;
begin
  TempImage := TDIBSharedImage.Create;
  try
    TempImage.ReadData(Stream, FImage.FMemoryImage);
  except
    TempImage.Free;
    raise;
  end;
  SetImage(TempImage);
end;

procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
var
  P: Pointer;
  Stream: TMemoryStream;
begin
  AFormat := CF_DIB;
  APalette := 0;

  Stream := TMemoryStream.Create;
  try
    WriteData(Stream);

    AData := GlobalAlloc(GHND, Stream.Size);
    if AData = 0 then OutOfMemoryError;

    P := GlobalLock(AData);
    Move(Stream.Memory^, P^, Stream.Size);
    GlobalUnLock(AData);
  finally
    Stream.Free;
  end;
end;

procedure TDIB.SaveToStream(Stream: TStream);
var
  BF: TBitmapFileHeader;
begin
  if Empty then Exit;

  with BF do
  begin
    bfType := BitmapFileType;
    bfOffBits := SizeOf(TBitmapFileHeader) + BitmapInfoSize;
    bfSize := bfOffBits + FImage.FBitmapInfo^.bmiHeader.biSizeImage;
    bfReserved1 := 0;
    bfReserved2