sf_bitmap.pas

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

{ TsfBitmap ===================================================================}

constructor TsfBitmap.Create;
begin
  inherited Create;
  FDC := 0;
  {$IFNDEF AL_CLX}
  with FBitmapInfo.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biPlanes := 1;
    biBitCount := 32;
    biCompression := BI_RGB;
  end;
  {$ENDIF}
end;

destructor TsfBitmap.Destroy;
begin
  RemoveBitmapFromList(Self);
  {$IFNDEF AL_CLX}
  if FCanvas <> nil then
  begin
    FCanvas.Handle := 0;
    FreeAndNil(FCanvas);
  end;
  if FDC <> 0 then DeleteDC(FDC);
  FDC := 0;
  if FHandle <> 0 then DeleteObject(FHandle);
  FHandle := 0;
  FBits := nil;
  {$ELSE}
  if FPainter <> nil then QPainter_destroy(FPainter);
  FPainter := nil;
  if FImage <> nil then QImage_destroy(FImage);
  FImage := nil;
  FBits := nil;
  {$ENDIF}
  inherited Destroy;
end;

procedure TsfBitmap.AssignTo(Dest: TPersistent);
var
  Bmp: TBitmap;

  procedure CopyToBitmap(Bmp: TBitmap);
  begin
    Bmp.PixelFormat := pf32Bit;
    Bmp.Width := FWidth;
    Bmp.Height := FHeight;
    Draw(Bmp.Canvas, 0, 0);
  end;

begin
  if Dest is TPicture then CopyToBitmap(TPicture(Dest).Bitmap)
  else if Dest is TBitmap then CopyToBitmap(TBitmap(Dest))
  else if Dest is TClipboard then
  begin
    Bmp := TBitmap.Create;
    try
      CopyToBitmap(Bmp);
      TClipboard(Dest).Assign(Bmp);
    finally
      Bmp.Free;
    end;
  end
  else inherited;
end;

procedure TsfBitmap.Assign(Source: TPersistent);

  procedure AssignFromBitmap(SrcBmp: TBitmap);
  begin
    SetSize(SrcBmp.Width, SrcBmp.Height);
    if Empty then Exit;
    {$IFNDEF AL_CLX}
    BitBlt(FDC, 0, 0, FWidth, FHeight, SrcBmp.Canvas.Handle, 0, 0, SRCCOPY);
    {$ELSE}
    DrawGraphicToBitmap(SrcBmp, Rect(0, 0, FWidth, FHeight));
    {$ENDIF}
    SetAlpha($FF);
  end;

var
  SLine: PsfColorArray;
  DstP: PsfColor;
  i, j: integer;
begin
  if Source is TsfBitmap then
  begin
    SetSize((Source as TsfBitmap).FWidth, (Source as TsfBitmap).FHeight);
    if Empty then Exit;
    MoveLongwordFunc((Source as TsfBitmap).Bits, FBits, FWidth * FHeight);
    { Assign properties }
    FName := (Source as TsfBitmap).FName;
    FTransparent := (Source as TsfBitmap).FTransparent;
    FAlphaBlend := (Source as TsfBitmap).FAlphaBlend;
  end
  else
    if Source is TBitmap then
    begin
      if ((Source as TBitmap).PixelFormat = pf32bit) and
         ((Source as TBitmap).HandleType = bmDIB) then
      with (Source as TBitmap) do
      begin
        { Alpha }
        SetSize(Width, Height);
        { Copy alpha }
        for j := 0 to Height - 1 do
        begin
          SLine := Scanline[j];
          for i := 0 to Width - 1 do
          begin
            DstP := PixelPtr[i, j];
            DstP^ := SLine^[i];
          end;
        end;
        { CheckAlpha }
        CheckingAlphaBlend; 
      end
      else
      begin
        { Copy }
        AssignFromBitmap((Source as TBitmap));
        SetAlpha($FF);
      end;
    end
    else
      if Source is TGraphic then
      begin
        SetSize(TGraphic(Source).Width, TGraphic(Source).Height);
        if Empty then Exit;
        DrawGraphic(TGraphic(Source), Rect(0, 0, FWidth, FHeight));
        SetAlpha($FF);
      end
      else
        if Source is TPicture then
        begin
          with TPicture(Source) do
          begin
            if TPicture(Source).Graphic is TBitmap then
              AssignFromBitmap(TBitmap(TPicture(Source).Graphic))
            else
            begin
              // icons, metafiles etc...
              SetSize(TPicture(Source).Graphic.Width, TPicture(Source).Graphic.Height);
              if Empty then Exit;
              DrawGraphic(TPicture(Source).Graphic, Rect(0, 0, FWidth, FHeight));
              SetAlpha($FF);
            end;
          end;
        end
        else  { inherited }
          inherited;
end;

procedure TsfBitmap.SetSize(AWidth, AHeight: Integer);
begin
  {$IFNDEF AL_CLX}
    AWidth := Abs(AWidth);
    AHeight := Abs(AHeight);
    if (AWidth = 0) or (AHeight = 0) then Exit;
    if (AWidth = FWidth) and (AHeight = FHeight) then Exit;

    { Free resource }
    if FDC <> 0 then RemoveBitmapFromList(Self);
    if FDC <> 0 then DeleteDC(FDC);
    FDC := 0;
    if FHandle <> 0 then DeleteObject(FHandle);
    FHandle := 0;
    FBits := nil;

    { Initialization }
    with FBitmapInfo.bmiHeader do
    begin
      biWidth := AWidth;
      biHeight := -AHeight;
    end;

    { Create new DIB }
    FHandle := CreateDIBSection(0, FBitmapInfo, DIB_RGB_COLORS, Pointer(FBits), 0, 0);
    if FBits = nil then
      raise Exception.Create('Can''t allocate the DIB handle');

    FDC := CreateCompatibleDC(0);
    if FDC = 0 then
    begin
      DeleteObject(FHandle);
      FHandle := 0;
      FBits := nil;
      raise Exception.Create('Can''t create compatible DC');
    end;

    if SelectObject(FDC, FHandle) = 0 then
    begin
      DeleteDC(FDC);
      DeleteObject(FHandle);
      FDC := 0;
      FHandle := 0;
      FBits := nil;
      raise Exception.Create('Can''t select an object into DC');
    end;

    { Add to BitmapList }
    AddBitmapToList(Self);
    if FCanvas <> nil then
      FCanvas.Handle := DC;

  {$ELSE}
    AWidth := Abs(AWidth);
    AHeight := Abs(AHeight);
    if (AWidth = 0) or (AHeight = 0) then Exit;
    if (AWidth = FWidth) and (AHeight = FHeight) then Exit;

    { Free resource }
    if FPainter <> nil then QPainter_destroy(FPainter);
    FPainter := nil;
    if FImage <> nil then QImage_destroy(FImage);
    FImage := nil;
    FBits := nil;

    { Initialization }
    FImage := QImage_create(AWidth, AHeight, 32, 0, QImageEndian_IgnoreEndian);
    if FImage = nil then
    begin
      FPainter := nil;
      FImage := nil;
      FBits := nil;
      raise Exception.Create('Can''t create QImage');
    end;

    FPainter := QPainter_create;
    if FPainter = nil then
    begin
      FPainter := nil;
      FImage := nil;
      FBits := nil;
      raise Exception.Create('Can''t create QPainter');
    end;

    FBits := PsfColorArray(QImage_bits(FImage));
  {$ENDIF}

  FWidth := AWidth;
  FHeight := AHeight;
end;

function TsfBitmap.Empty: boolean;
begin
  {$IFNDEF AL_CLX}
  Result := FHandle = 0;
  {$ELSE}
  Result := FImage = nil;
  {$ENDIF}
end;

procedure TsfBitmap.Clear(Color: TsfColor);
begin
  FillLongwordFunc(Bits, FWidth * FHeight, Color);
end;

{ I/O Routines }

procedure TsfBitmap.LoadFromResource(const ResFileName, ResName: string);
var
  H: THandle;
  ResStream: TStream;
  BitmapInfo: PBitmapInfo;
  HeaderSize: integer;
  B: TBitmap;
  Bmp: HBitmap;
  HResInfo: HRSRC;
begin
  H := LoadLibraryEx(PChar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
  try
    HResInfo := FindResource(H, PChar(ResName), RT_BITMAP);
    if HResInfo <> 0 then
    begin
      ResStream := TResourceStream.Create(H, ResName, RT_BITMAP);
      try
        ResStream.Read(HeaderSize, sizeof(HeaderSize));
        GetMem(BitmapInfo, HeaderSize + 12 + 256 * sizeof(TRGBQuad));
        with BitmapInfo^ do
        try
          ResStream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
            HeaderSize - sizeof(HeaderSize));

          B := TBitmap.Create;
          try
            if BitmapInfo^.bmiHeader.biBitCount = 32 then
              B.LoadFromResourceName(H, ResName) // By VCL
            else
            begin
              B.Handle := LoadBitmap(H, PChar(ResName)); // By Windows
              if B.Handle = 0 then
                B.LoadFromResourceName(H, ResName) // Try by VCL
            end;

            Assign(B);
          finally
            B.Free;
          end;
        finally
          FreeMem(BitmapInfo);
        end;
      finally
        ResStream.Free;
      end;
    end;
  finally
    FreeLibrary(H);
  end;
end;

procedure TsfBitmap.LoadFromStream(Stream: TStream);
var
  W, H: integer;
begin
  FName := ReadString(Stream);
  Stream.Read(W, SizeOf(Integer));
  Stream.Read(H, SizeOf(Integer));
  if (H > 0) then
  begin
    { New format since 3.4.4 }
    SetSize(W, H);
    if (FWidth = W) and (FHeight = H) then
      Stream.Read(FBits^, FWidth * FHeight * SizeOf(Longword));
  end
  else
  begin
    H := Abs(H);
    SetSize(W, H);
    if (FWidth = W) and (FHeight = H) then
      Stream.Read(FBits^, FWidth * FHeight * SizeOf(Longword));
    FlipHorz;
  end;
  { Checking }
{  CheckingAlphaBlend;
  if not FAlphaBlend then CheckingTransparent;}
end;

procedure TsfBitmap.SaveToStream(Stream: TStream);
var
  NewFormatHeight: integer;
begin
  WriteString(Stream, FName);
  Stream.Write(FWidth, SizeOf(Integer));
  NewFormatHeight := FHeight; { New format since 3.4.4 }
  Stream.Write(NewFormatHeight, SizeOf(Integer));
  Stream.Write(FBits^, FWidth * FHeight * SizeOf(Longword));
end;

type

  TRGB = packed record
   R, G, B: Byte;
  end;

  TPCXHeader = record
    FileID: Byte;                      // $0A for PCX files, $CD for SCR files
    Version: Byte;                     // 0: version 2.5; 2: 2.8 with palette; 3: 2.8 w/o palette; 5: version 3
    Encoding: Byte;                    // 0: uncompressed; 1: RLE encoded
    BitsPerPixel: Byte;
    XMin,
    YMin,
    XMax,
    YMax,                              // coordinates of the corners of the image
    HRes,                              // horizontal resolution in dpi
    VRes: Word;                        // vertical resolution in dpi
    ColorMap: array[0..15] of TRGB;    // color table
    Reserved,
    ColorPlanes: Byte;                 // color planes (at most 4)
    BytesPerLine,                      // number of bytes of one line of one plane
    PaletteType: Word;                 // 1: color or b&w; 2: gray scale
    Fill: array[0..57] of Byte;
  end;

procedure TsfBitmap.LoadFromPcxStream(Stream: TStream);
const
  FSourceBPS: byte = 8;
  FTargetBPS: byte = 8;
var
  Header: TPCXHeader;
  Bitmap: TBitmap;

  procedure PcxDecode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer);
  var
    Count: Integer;
    SourcePtr,
    TargetPtr: PByte;
  begin
    SourcePtr := Source;
    TargetPtr := Dest;
    while UnpackedSize > 0 do
    begin
      if (SourcePtr^ and $C0) = $C0 then
      begin
        // RLE-Code
        Count := SourcePtr^ and $3F;
        Inc(SourcePtr);
        if UnpackedSize < Count then Count := UnpackedSize;
        FillChar(TargetPtr^, Count, SourcePtr^);
        Inc(SourcePtr);
        Inc(TargetPtr, Count);
        Dec(UnpackedSize, Count);
      end
      else
      begin
        // not compressed
        TargetPtr^ := SourcePtr^;
        Inc(SourcePtr);
        Inc(TargetPtr);
        Dec(UnpackedSize);
      end;
    end;
  end;

  function PcxCreateColorPalette(Data: array of Pointer; ColorCount: Cardinal): HPALETTE;
  var
    I, MaxIn, MaxOut: Integer;
    LogPalette: TMaxLogPalette;
    RunR8: PByte;
  begin
    FillChar(LogPalette, SizeOf(LogPalette), 0);
    LogPalette.palVersion := $300;
    if ColorCount > 256 then
      LogPalette.palNumEntries := 256
    else
      LogPalette.palNumEntries := ColorCount;

    RunR8 := Data[0];

    for I := 0 to LogPalette.palNumEntries - 1 do
    begin
      LogPalette.palPalEntry[I].peRed := RunR8^;
      Inc(RunR8);
      LogPalette.palPalEntry[I].peGreen := RunR8^;
      Inc(RunR8);
      LogPalette.palPalEntry[I].peBlue := RunR8^; Inc(
      RunR8);
    end;

    MaxIn := (1 shl FSourceBPS) - 1;
    MaxOut := (1 shl FTargetBPS) - 1;
    if (FTargetBPS <= 8) and (MaxIn <> MaxOut) then
    begin
      MaxIn := (1 shl FSourceBPS) - 1;
      MaxOut := (1 shl FTargetBPS) - 1;
      if MaxIn < MaxOut then
      begin
        { palette is too small, enhance it }
        for I := MaxOut downto 0 do
        begin
          LogPalette.palPalEntry[I].peRed := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peRed;
          LogPalette.palPalEntry[I].peGreen := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peGreen;
          LogPalette.palPalEntry[I].peBlue := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peBlue;
        end;
      end
      else
      begin
        { palette contains too many entries, shorten it }
        for I := 0 to MaxOut do
        begin
          LogPalette.palPalEntry[I].peRed := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peRed;
          LogPalette.palPalEntry[I].peGreen := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peGreen;
          LogPalette.palPalEntry[I].peBlue := LogPalette.palPalEntry[MulDiv16(I, MaxIn, MaxOut)].peBlue;
        end;
      end;
      LogPalette.palNumEntries := MaxOut + 1;
    end;

    { finally create palette }
    Result := CreatePalette(PLogPalette(@LogPalette)^);
  end;