sf_bitmap.pas

smartflash ,delphi vcl组件 ,可以实现透明flash窗体

  procedure MakePalette;
  var
    PCXPalette: array[0..255] of TRGB;
    OldPos: Integer;
    Marker: Byte;
  begin
    if (Header.Version <> 3) or (Bitmap.PixelFormat = pf1Bit) and
       (Bitmap.PixelFormat = pf8Bit) then
    begin
      OldPos := Stream.Position;
      { 256 colors with 3 components plus one marker byte }
      Stream.Position := Stream.Size - 769;
      Stream.Read(Marker, 1);

      Stream.Read(PCXPalette[0], 768);
      Bitmap.Palette := PcxCreateColorPalette([@PCXPalette], 256);

      Stream.Position := OldPos;
    end
    else
      Bitmap.Palette := SystemPalette16;
  end;

  procedure RowConvertIndexed8(Source: array of Pointer; Target: Pointer; Count: Cardinal; Mask: Byte);
  var
    SourceRun, TargetRun: PByte;
  begin
    SourceRun := Source[0];
    TargetRun := Target;

    if (FSourceBPS = FTargetBPS) and (Mask = $FF) then
      Move(SourceRun^, TargetRun^, (Count * FSourceBPS + 7) div 8);
  end;

var
  PCXSize, Size: Cardinal;
  RawBuffer, DecodeBuffer: Pointer;
  Run: PByte;
  I: Integer;
  Line: PByte;
  Increment: Cardinal;
begin
  { Load from PCX - 8-bit indexed RLE compressed/uncompressed }
  {$WARNINGS OFF}
  Bitmap := TBitmap.Create;
  try
    Bitmap.Handle := 0;

    Stream.Read(Header, SizeOf(Header));
    PCXSize := Stream.Size - Stream.Position;
    with Header do
    begin
      if not (FileID in [$0A, $CD]) then Exit;

      Bitmap.PixelFormat := pf8bit;
      MakePalette;

      Bitmap.Width := XMax - XMin + 1;
      Bitmap.Height := YMax - YMin + 1;

      { adjust alignment of line }
      Increment := ColorPlanes * BytesPerLine;

      { Decompress }
      if Header.Encoding = 1 then
      begin
        { RLE }
        Size := Increment * Bitmap.Height;
        GetMem(DecodeBuffer, Size);
        GetMem(RawBuffer, PCXSize);
        try
          Stream.ReadBuffer(RawBuffer^, PCXSize);

          PcxDecode(RawBuffer, DecodeBuffer, PCXSize, Size);
        finally
          if Assigned(RawBuffer) then FreeMem(RawBuffer);
        end;
      end
      else
      begin
        GetMem(DecodeBuffer, PCXSize);
        Stream.ReadBuffer(DecodeBuffer^, PCXSize);
      end;

      try
        Run := DecodeBuffer;
        { PCX 8 bit Index }
        for I := 0 to Bitmap.Height - 1 do
        begin
          Line := Bitmap.ScanLine[I];
          RowConvertIndexed8([Run], Line, Bitmap.Width, $FF);
          Inc(Run, Increment);
        end;
      finally
        if Assigned(DecodeBuffer) then FreeMem(DecodeBuffer);
      end;
    end;

    { Assign to Self }
    Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
  {$WARNINGS ON}
end;

{ Checking routines }

const
  Quantity = 6;

procedure TsfBitmap.CheckingAlphaBlend;
var
  i: Cardinal;
  C: PsfColor;
begin
  FAlphaBlend := false;

  C := @FBits[0];
  for i := 0 to FWidth * FHeight - 1 do
  begin
    if (TsfColorRec(C^).A > 0) and (TsfColorRec(C^).A < $FF) then
    begin
      FAlphaBlend := true;
      Break;
    end;

    Inc(C);
  end;
end;

procedure TsfBitmap.CheckingAlphaBlend(ARect: TRect);
var
  i, j: integer;
  C: PsfColor;
begin
  FAlphaBlend := false;

  for i := 0 to FWidth - 1 do
    for j := 0 to FHeight - 1 do
    begin
      C := PixelPtr[i, j];
      if (TsfColorRec(C^).A > 0) and (TsfColorRec(C^).A < $FF) then
      begin
        FAlphaBlend := true;
        Break;
      end;
    end;
end;

procedure TsfBitmap.CheckingTransparent(Color: TsfColor = sfTransparent);
var
  i: Cardinal;
  C: PsfColor;
begin
  FTransparent := false;

  C := @FBits[0];
  for i := 0 to FWidth * FHeight - 1 do
  begin
    if (Abs(TsfColorRec(C^).R - TsfColorRec(Color).R) < Quantity) and
       (Abs(TsfColorRec(C^).G - TsfColorRec(Color).G) < Quantity) and
       (Abs(TsfColorRec(C^).B - TsfColorRec(Color).B) < Quantity)
    then
    begin
      C^ := sfTransparent;
      FTransparent := true;
    end;

    Inc(C);
  end;
end;

procedure TsfBitmap.CheckingTransparent(ARect: TRect; Color: TsfColor = sfTransparent);
var
  i, j: integer;
  C: PsfColor;
begin
  FTransparent := false;

  for i := 0 to FWidth - 1 do
    for j := 0 to FHeight - 1 do
    begin
      C := PixelPtr[i, j];
      if (Abs(TsfColorRec(C^).R - TsfColorRec(Color).R) < Quantity) and
         (Abs(TsfColorRec(C^).G - TsfColorRec(Color).G) < Quantity) and
         (Abs(TsfColorRec(C^).B - TsfColorRec(Color).B) < Quantity)
      then
      begin
        C^ := sfTransparent;
        FTransparent := true;
      end;
    end;
end;

procedure TsfBitmap.SetAlpha(Alpha: byte);
begin
  if Empty then Exit;
  FillAlphaFunc(Bits, FWidth * FHeight, Alpha);
end;

procedure TsfBitmap.SetAlpha(Alpha: byte; Rect: TRect);
begin
  if RectWidth(Rect) = 0 then Exit;
  if RectHeight(Rect) = 0 then Exit;

  if Rect.Left < 0 then Rect.Left := 0;
  if Rect.Top < 0 then Rect.Top := 0;
  if Rect.Right > FWidth then Rect.Right := FWidth;
  if Rect.Bottom > FHeight then Rect.Bottom := FHeight;
  FillAlphaRectFunc(FBits, FWidth, FHeight, Rect.Left, Rect.Top, Rect.Right-1,
    Rect.Bottom - 1, Alpha);
end;

{ Access properties }

function TsfBitmap.GetScanLine(Y: Integer): PsfColorArray;
begin
  Result := @Bits[Y * FWidth];
end;

function TsfBitmap.GetPixelPtr(X, Y: Integer): PsfColor;
begin
  Result := @Bits[X + Y * FWidth];
end;

function TsfBitmap.GetPixel(X, Y: Integer): TsfColor;
begin
  if (FBits <> nil) and (X >= 0) and (Y >= 0) and (X < Width) and (Y < Height) then
    Result := PixelPtr[X, Y]^
  else
    Result := 0;
end;

procedure TsfBitmap.SetPixel(X, Y: Integer; Value: TsfColor);
begin
  if X < 0 then Exit;
  if Y < 0 then Exit;
  if X > Width then Exit;
  if Y > Height then Exit;

  if FBits <> nil then
    PixelPtr[X, Y]^ := Value;
end;

{ BitmapLink }

function TsfBitmap.GetBitmapLink(Rect: TRect): TsfBitmapLink;
begin
  Result := TsfBitmapLink.Create;
  Result.Image := Self;
  Result.Name := Name;
  Result.Rect := Rect;
end;

function TsfBitmap.GetBitmapLink(Rect: string): TsfBitmapLink;
begin
  Result := TsfBitmapLink.Create;
  Result.Image := Self;
  Result.Name := Name;
  Result.Rect := StringToRect(Rect);
end;

{ Color transition ============================================================}

procedure TsfBitmap.ChangeBitmapBrightness(DeltaBrightness: integer);
var
  i: Cardinal;
  Color: PsfColor;
  A: byte;
begin
  if DeltaBrightness = 0 then Exit;
  if FWidth * FHeight = 0 then Exit;

  for i := 0 to FWidth * FHeight - 1 do
  begin
    Color := @Bits[i];
    A := TsfColorRec(Color^).A;
    if (A = 0) then Continue;
    Color^ := ChangeBrightness(Color^, DeltaBrightness);
    Color^ := Color^ and not AlphaMask or (A shl 24);
  end;
end;

procedure TsfBitmap.SetBitmapHue(Hue: integer);
var
  i: Cardinal;
  Color: PsfColor;
  A: byte;
begin
  if FWidth * FHeight = 0 then Exit;

  for i := 0 to FWidth * FHeight - 1 do
  begin
    Color := @Bits[i];
    A := TsfColorRec(Color^).A;
    if (A = 0) then Continue;
    Color^ := SetHue(Color^, Hue);
    Color^ := Color^ and not AlphaMask or (A shl 24);
  end;
end;

procedure TsfBitmap.ChangeBitmapSat(DeltaSat: integer);
var
  i: Cardinal;
  Color: PsfColor;
  A: byte;
begin
  if DeltaSat = 0 then Exit;
  if FWidth * FHeight = 0 then Exit;

  for i := 0 to FWidth * FHeight - 1 do
  begin
    Color := @Bits[i];
    A := TsfColorRec(Color^).A;
    if (A = 0) then Continue;
    Color^ := ChangeSat(Color^, DeltaSat);
    Color^ := Color^ and not AlphaMask or (A shl 24);
  end;
end;

procedure TsfBitmap.ChangeBitmapHue(DeltaHue: integer);
var
  i: Cardinal;
  Color: PsfColor;
  A: byte;
begin
  if DeltaHue = 0 then Exit;
  if FWidth * FHeight = 0 then Exit;

  for i := 0 to FWidth * FHeight - 1 do
  begin
    Color := @Bits[i];
    A := TsfColorRec(Color^).A;
    if (A = 0) then Continue;
    Color^ := ChangeHue(Color^, DeltaHue);
    Color^ := Color^ and not AlphaMask or (A shl 24);
  end;
end;

{ Draw to XXX =================================================================}

procedure TsfBitmap.Draw(DC: HDC; X, Y: integer);
begin
  Draw(DC, X, Y, Rect(0, 0, Width, Height));
end;

procedure TsfBitmap.Draw(DC: HDC; X, Y: integer; SrcRect: TRect);
begin
  Draw(DC, Rect(X, Y, X + RectWidth(SrcRect), Y + RectHeight(SrcRect)), SrcRect);
end;

procedure TsfBitmap.Draw(DC: HDC; DstRect: TRect);
begin
  Draw(DC, DstRect, Rect(0, 0, FWidth, FHeight));
end;

procedure TsfBitmap.Draw(DC: HDC; DstRect, SrcRect: TRect);
{$WARNINGS OFF}
var
  Dst: TsfBitmap;
  P: TPoint;
  BitmapW, BitmapH, BitmapBCount: integer;
  BitmapBits: PByteArray;
begin
  Dst := FindBitmapByDC(DC);
  if Dst <> nil then
  begin
    { Adjust WindowOrg }
    GetWindowOrgEx(DC, P);
    OffsetRect(DstRect, -P.X, -P.Y);
    { Destination is TsfBitmap }
    Draw(Dst, DstRect, SrcRect);
  end
  else
  begin
(*    BitmapBits := GetBitsFromDCFunc(DC, BitmapW, BitmapH, BitmapBCount);
    if EnableDibOperation and (BitmapBits <> nil) and (BitmapBCount = 32) and (BitmapH > 0) then
    begin
      { Adjust WindowOrg }
      GetWindowOrgEx(DC, P);
      OffsetRect(DstRect, -P.X, -P.Y);
      { Draw to DIB }
      if FAlphaBlend then
        StretchToDibAlphaBlendFunc(BitmapBits, DstRect, DstRect, BitmapW, BitmapH,
          Self, SrcRect)
      else
        if FTransparent then
          StretchToDibTransparentFunc(BitmapBits, DstRect, DstRect, BitmapW, BitmapH,
            Self, SrcRect)
        else
          StretchToDibOpaqueFunc(BitmapBits, DstRect, DstRect, BitmapW, BitmapH,
            Self, SrcRect);
    end
    else *)
    begin
      { Draw to DC }
      if FAlphaBlend then
        StretchToDCAlphaBlendFunc(DC, DstRect.Left, DstRect.Top, RectWidth(DstRect), RectHeight(DstRect),
          Self, SrcRect.Left, SrcRect.Top, RectWidth(SrcRect), RectHeight(SrcRect))
      else
        if FTransparent then
          StretchToDCTransparentFunc(DC, DstRect.Left, DstRect.Top, RectWidth(DstRect), RectHeight(DstRect),
            Self, SrcRect.Left, SrcRect.Top, RectWidth(SrcRect), RectHeight(SrcRect))
        else
          StretchToDCOpaqueFunc(DC, DstRect.Left, DstRect.Top, RectWidth(DstRect), RectHeight(DstRect),
            Self, SrcRect.Left, SrcRect.Top, RectWidth(SrcRect), RectHeight(SrcRect));
    end;
  end;
{$WARNINGS ON}
end;

procedure TsfBitmap.Draw(Canvas: TCanvas; X, Y: integer);
begin
  {$IFNDEF AL_CLX}
  Draw(Canvas.Handle, X, Y);
  {$ELSE}
  Canvas.Start;
  try
    QPainter_drawImage(Canvas.Handle, X, Y, FImage, 0, 0, FWidth, FHeight, -1);
  finally
    Canvas.Stop;
  end;
  {$ENDIF}
end;

procedure TsfBitmap.Draw(Canvas: TCanvas; X, Y: integer; SrcRect: TRect);
begin
  Draw(Canvas, Rect(X, Y, X + RectWidth(SrcRect), Y + RectHeight(SrcRect)), SrcRect);
end;

procedure TsfBitmap.Draw(Canvas: TCanvas; DstRect: TRect);
begin
  Draw(Canvas, DstRect, Rect(0, 0, FWidth, FHeight));
end;

procedure TsfBitmap.Draw(Canvas: TCanvas; DstRect, SrcRect: TRect);
begin
  {$IFNDEF AL_CLX}
  Draw(Canvas.Handle, DstRect, SrcRect);
  {$ELSE}
  Canvas.Start;
  try
    QPainter_drawImage(Canvas.Handle, X, Y, FImage, 0, 0, FWidth, FHeight, -1);
  finally
    Canvas.Stop;
  end;
  {$ENDIF}
end;

procedure TsfBitmap.Draw(Bitmap: TsfBitmap; X, Y: integer);
begin
  Draw(Bitmap, X, Y, Rect(0, 0, Width, Height));
end;

procedure TsfBitmap.Draw(Bitmap: TsfBitmap; X, Y: integer;
  SrcRect: TRect);
begin
  Draw(Bitmap, Rect(X, Y, X + RectWidth(SrcRect), Y + RectHeight(SrcRect)), SrcRect);
end;

procedure TsfBitmap.Draw(Bitmap: TsfBitmap; DstRect: TRect);
begin
  Draw(Bitmap, DstRect, Rect(0, 0, FWidth, FHeight));
end;

procedure TsfBitmap.Draw(Bitmap: TsfBitmap; DstRect, SrcRect: TRect);
begin
  if AlphaBlend then
    StretchAlphaBlendFunc(Bitmap, DstRect, DstRect, Self, SrcRect)
  else
    if Transparent then
      StretchTransparentFunc(Bitmap, DstRect, DstRect, Self, SrcRect)
    else
      StretchOpaqueFunc(Bitmap, DstRect, DstRect, Self, SrcRect)
end;