unitexicon.pas

海盗远控1.23源代码

  try
                                         // Get a bitmap with the required format
    src := CreateMappedBitmap (source, Palette, PixelFormat, Width, height);

    maskBmp.Assign (source);             // Get mask bitmap - White where the transparent color
                                         // occurs - otherwise black.

    if source is TBitmap then
      maskBmp.Mask (TBitmap (source).transparentColor)
    else
      if Source is TExIconCursor then
        maskBmp.Mask (TExIconCursor(source).transparentColor)
      else
        maskBmp.Mask (clBlack);

                                      // Get size for mask bits buffer
    maskImageSize := BytesPerScanLine (Width, 1, 32) * Height;

                                      // Get size for color bits buffer
    InternalGetDibSizes (src.Handle, infoHeaderSize, imageSize, PixelFormat);

                                      // Create a memory stream to assemble the icon image
    image := TExIconImage.Create;
    try
      image.Reference;
      image.FMemoryImage := TMemoryStream.Create;
      image.FIsIcon := Self is TExIcon;

      if image.FIsIcon then
        offset := 0
      else
        offset := sizeof (DWORD);

      image.FMemoryImage.Size := infoHeaderSize + imageSize + maskImageSize + offset;

      info := PBitmapInfo (PChar (image.FMemoryImage.Memory) + offset);
      colorBits := PChar (info) + infoHeaderSize;
      maskBits := colorBits + imageSize;

      InternalGetDib (src.Handle, Palette, info, colorBits^, PixelFormat);
                                       // Get the bitmap header, palette & bits


      maskInfo := nil;
      dc := CreateCompatibleDC (0);
      try
        GetMem (maskInfo, SizeOf (TBitmapInfoHeader) + 2 * SizeOf (RGBQUAD));
                                      // Get mask bits

        with maskInfo^.bmiHeader do  // Set the 1st six members of info header, according
        begin                        // to the docs.

          biSize := SizeOf (TBitmapInfoHeader);
          biWidth := Width;
          biHeight := Height;
          biBitCount := 1;
          biPlanes := 1;
          biCompression := BI_RGB;
        end;

        if GetDIBits (dc, maskBmp.Handle, 0, Height, maskBits, maskInfo^, DIB_RGB_COLORS) = 0 then
          RaiseLastOSError;
      finally
        DeleteDC (dc);
        FreeMem (maskInfo)
      end;

      MaskBitmapBits (colorBits, PixelFormat, maskBits, Width, Height, Palette);

      image.FWidth := info^.bmiHeader.biWidth;
      image.FHeight := info^.bmiHeader.biHeight;

      info^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2;
                                        // Adjust height for funky icon Height thing.

      image.FPixelFormat := src.PixelFormat;

      image.FGotPalette := False;  // ie.  we need to get it later if required.

      if Self is TExCursor then
        PDWORD (image.FMemoryImage.Memory)^ := TExCursor (Self).HotSpot;

      Images [fCurrentImage].Release;
      fImages [fCurrentImage] := Image;
      Changed (self);
    except
      image.Free;
      raise
    end;
  finally
    maskBmp.Free;
    src.Free
  end
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.AssignTo                                           |
 |                                                                            |
 | Allow assigning to bitmap                                                  |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.AssignTo(dest: TPersistent);
var
  bmp : TBitmap;
begin
  if dest is TBitmap then
  begin
    bmp := TBitmap (dest);
    bmp.Assign (nil);           // You gotta do this, otherwise transparency goes nuts!
    bmp.PixelFormat := pf24Bit; // Always assign to 24-bit Bitmap so we don't lose colors

    bmp.Width := Width;
    bmp.Height := Height;

    bmp.Transparent := True;
    bmp.TransparentColor := TransparentColor;
    bmp.Canvas.Brush.Color := TransparentColor;
    bmp.Canvas.FillRect (RECT (0, 0, Width, Height));
    bmp.Canvas.Draw (0, 0, self);
  end
  else
    inherited AssignTo (dest)
end;

(*----------------------------------------------------------------------------*
 | constructor TExIconCursor.Create                                           |
 |                                                                            |
 | Constructor for TExICon                                                    |
 *----------------------------------------------------------------------------*)
constructor TExIconCursor.Create;
begin
  inherited Create;
  FTransparentColor := RGB ($fe, $e6, $f8);
  SetLength (FImages, 1);
  FImages [0] := TExIconImage.Create;
  FImages [0].FIsIcon := self is TExIcon;
  Images [0].Reference;
end;

(*----------------------------------------------------------------------------*
 | destructor TExIconCursor.Destroy                                           |
 |                                                                            |
 | destructor for TExIconCursor                                               |
 *----------------------------------------------------------------------------*)
destructor TExIconCursor.Destroy;
begin
  ReleaseImages;
  inherited Destroy
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.Draw                                               |
 |                                                                            |
 | We should be able to do HandleNeeded/DrawIconEx, however we don't want to  |
 | call 'HandleNeeded' because of NT bugs, so jump through hoops to draw      |
 | direct from the memory image instead.                                      |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  monoBmp, oldMonoBmp : HBITMAP;
  colorBmp, oldColorBmp : HBITMAP;
  colorDC, monoDC, dc : HDC;
  bitsOffset, bitsSize : DWORD;
  info : PBitmapInfo;
  hdr : PBitmapInfoHeader;
  monoInfo : PBitmapInfo;
  bits : PChar;

begin
  with fImages [fCurrentImage] do
    if Assigned (fMemoryImage) then
    begin
      info := GetBitmapInfo;
      hdr := @info^.bmiHeader;

      colorBmp := 0;
      monoBmp := 0;
      oldColorBmp := 0;
      oldMonoBmp := 0;
      monoDC := 0;
      colorDC := 0;
      monoInfo := Nil;

      dc := GDICheck (GetDC (0));
      try
        hdr^.biHeight := hdr^.biHeight div 2;  // Adjust memory image for funky Icon Height thing.

        GetBitmapInfoSizes (hdr^, bitsOffset, bitsSize, False);

                                                // Create Color Bitmap from Color bits & ColorTable
        colorBmp := GDICheck (CreateDIBitmap (dc, info^.bmiHeader, CBM_INIT, PChar (info) + bitsOffset, info^, DIB_RGB_COLORS));
        colorDC := GDICheck (CreateCompatibleDC (0));
        oldColorBmp := GDICheck (SelectObject(colorDC, colorBmp));

                                                // Create mono bitmap.  For some reason, CreateBitmap
                                                // creates it upside down if you give it the bits - so
                                                // you have to do CreateBitmap followed by SetDIBtes

        GetMem (monoInfo, sizeof (TBitmapInfoHeader) + 2 * sizeof (RGBQUAD));
        Move (hdr^, monoInfo^, sizeof (TBitmapInfoHeader));
        monoInfo^.bmiHeader.biBitCount := 1;
        monoInfo^.bmiHeader.biCompression := 0;
        with PRGBQUAD (PChar (monoInfo) + sizeof (TBitmapInfoHeader) + sizeof (RGBQUAD))^ do
        begin
          rgbRed := $ff;
          rgbGreen := $ff;
          rgbBlue := $ff;
          rgbReserved := 0;
        end;

        monoBmp := GDICheck (CreateBitmap (hdr^.biWidth, hdr^.biHeight, 1, 1, Nil));
        bits := PChar (info) + bitsOffset + bitsSize;
        monoDC := GDICheck (CreateCompatibleDC (0));
        GDICheck (SetDIBits (monoDC, monoBmp, 0, hdr^.biHeight, bits, monoInfo^, DIB_RGB_COLORS));
        oldMonoBmp := GDICheck (SelectObject(monoDC, monoBmp));

                                                // Draw the masked bitmap

        with rect do TransparentStretchBlt (ACanvas.Handle,
                               left, top, right - left, bottom - top,
                               colorDC, 0, 0,
                               hdr^.biWidth, hdr^.biHeight, monoDC, 0, 0);

      finally
        hdr^.biHeight := hdr^.biHeight * 2;

        if oldMonoBmp <> 0 then SelectObject (monoDC, oldMonoBmp);
        if monoDC <> 0 then DeleteDC (monoDC);

        if oldColorBmp <> 0 then SelectObject (colorDC, oldColorBmp);
        if colorDC <> 0 then DeleteDC (colorDC);

        if colorBmp <> 0 then DeleteObject (colorBmp);
        if monoBmp <> 0 then DeleteObject (monoBmp);
        ReleaseDC (0, dc);
        if monoInfo <> Nil then FreeMem (monoInfo)
      end
   end
    else
    begin

    // If you've fed an HICON in directly to the handle property you'll get here.
    // DrawIconEx seems to work - it's CreateIconFromresourceex that blows up...

      if Handle <> 0 then
        with rect do DrawIconEx (ACanvas.Handle, left, top, Handle, right - left, bottom - top, 0, 0, DI_NORMAL)
    end
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetEmpty                                            |
 |                                                                            |
 | Returns true if the TExIconCursor's current image  has neither a handle or |
 | an image                                                                   |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetEmpty: Boolean;
begin
  with FImages [fCurrentImage] do
    Result := (FHandle = 0) and (FMemoryImage = nil);
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetHandle                                           |
 |                                                                            |
 | Returns the current image's icon handle.  Calls HandleNeeded which may not |
 | be reliable under NT.                                                      |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetHandle: HICON;
begin
  HandleNeeded;
  result := Images [fCurrentImage].Handle
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetHeight                                           |
 |                                                                            |
 | Returns the current image's height in pixels                               |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetHeight: Integer;
begin
  result := FImages [fCurrentImage].FHeight;
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetImage                                            |
 |                                                                            |
 | Get the current image TExIconImage instance                                |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetImage(index: Integer): TExIconImage;
begin
  result := fImages [index]
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetImageCount                                       |
 |                                                                            |
 | Get the nuber of images in the current icon or cursor                      |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetImageCount: Integer;
begin
  result := Length (fImages);
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetPalette                                          |
 |                                                                            |
 | Get the palette handle for the current image                               |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetPalette: HPALETTE;
begin
  PaletteNeeded;
  result := FImages [fCurrentImage].fPalette;
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetPixelFormat : TPixelFormat                       |
 |                                                                            |
 | Get the pixel format for the current image                                 |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetPixelFormat: TPixelFormat;
begin
  result := FImages [fCurrentImage].fPixelFormat
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetTransparent : boolean                            |
 |                                                                            |
 | Overrides TGraphic method to always return TRUE                            |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetTransparent: boolean;
begin
  result := True
end;

(*----------------------------------------------------------------------------*
 | function TExIconCursor.GetWidth : Integer                                  |
 |                                                                            |
 | Returns the current image's width in pixels                                |
 *----------------------------------------------------------------------------*)
function TExIconCursor.GetWidth: Integer;
begin
  result := FImages [fCurrentImage].FWidth;
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.HandleNeeded                                       |
 |                                                                            |
 | Ensure that an HICON handle exists for the current image.  Don't use this  |
 | unless strictly necessary.  It may bugger up in NT4                        |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.HandleNeeded;
begin
  FImages [FCurrentImage].HandleNeeded;
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.ImageNeeded                                        |
 |                                                                            |
 | Ensure that a memory image exists for the current image.                   |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.ImageNeeded;
begin