unitexicon.pas

灰鸽子VIP1.2经典源代码

    for i := 0 to ImageCount - 1 do
    begin
      FCurrentImage := i;
      ImageNeeded;
      image := Images [i];

      FillChar (dirEntry, SizeOf (dirEntry), 0);

      dirEntry.bWidth := image.Width;
      dirEntry.bHeight := image.Height;

      case image.PixelFormat of
        pf1Bit  : begin dirEntry.bColorCount :=  2; dirEntry.wBitCount :=  0; end;
        pf4Bit  : begin dirEntry.bColorCount := 16; dirEntry.wBitCount :=  0; end;
        pf8Bit  : begin dirEntry.bColorCount :=  0; dirEntry.wBitCount :=  8; end;
        pf16Bit : begin dirEntry.bColorCount :=  0; dirEntry.wBitCount := 16; end;
        pf24Bit : begin dirEntry.bColorCount :=  0; dirEntry.wBitcount := 24; end;
        pf32Bit : begin dirEntry.bColorCount :=  0; dirEntry.wBitCount := 32; end;
        else
          raise EInvalidGraphic.Create (rstInvalidIcon);
      end;

      dirEntry.wPlanes := 1;
      dirEntry.dwBytesInRes := image.FMemoryImage.Size;
      dirEntry.dwImageOffset := dirSize + offset;

      Stream.Write (dirEntry, SizeOf (dirEntry));
      Inc (offset, dirEntry.dwBytesInRes);
    end
  finally
    FCurrentImage := oldCurrentImage
  end;

  for i := 0 to ImageCount - 1 do
    images [i].FMemoryImage.SaveToStream (Stream);
end;

procedure TExIconCursor.SetCurrentImage(const Value: Integer);
begin
  if fCurrentImage <> value then
  begin
    fCurrentImage := Value;
    Changed (self)
  end
end;

procedure TExIconCursor.SetHandle(const Value: HICON);
var
  iconInfo : TIconInfo;
  BI : TBitmapInfoHeader;
  image : TExIconImage;
begin
  if GetIconInfo (value, iconInfo) then
  try
    image := TExIconImage.Create;
    try
      InitializeBitmapInfoHeader (iconInfo.hbmColor, BI, pfDevice);
      image.FIsIcon := self is TExIcon;
      image.FWidth := BI.biWidth;
      image.FHeight := BI.biHeight;
      image.FPixelFormat := GetBitmapInfoPixelFormat (BI);
    except
      image.Free;
      raise
    end;

    image.FHandle := Value;

    Images [fCurrentImage].Release;
    fImages [fCurrentImage] := image;
    image.Reference;
    Changed(Self)
  finally
    DeleteObject (iconInfo.hbmMask);
    DeleteObject (iconInfo.hbmColor)
  end
  else
    RaiseLastOSError;
end;

procedure TExIconCursor.SetHeight(Value: Integer);
begin
  if Value = Height then Exit;
  Images [FCurrentImage].FHeight := Value;
  AssignFromGraphic (Self);
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.SetPalette                                         |
 |                                                                            |
 | Modify the icon so it uses a new palette (with maybe a differnt color      |
 | count, hence pixel format...                                               |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.SetPalette(Value: HPALETTE);
var
  colorCount : DWORD;
  newPixelFormat : TPixelFormat;
begin
  newPixelFormat := pfDevice;
  colorCount := 0;
  if GetObject (Value, sizeof (colorCount), @colorCount) = 0 then
    RaiseLastOSError;

  case colorCount of
    1..2    : newPixelFormat := pf1Bit;
    3..16   : newPixelFormat := pf4Bit;
    17..256 : newPixelFormat := pf8Bit;
  end;

  if FImages [FCurrentImage].FPalette <> 0 then
    DeleteObject (FImages [FCurrentImage].FPalette);

  if newPixelFormat <> pfDevice then
  begin
    FImages [FCurrentImage].FPixelFormat := newPixelFormat;

    FImages [FCurrentImage].FPalette := CopyPalette (Value);
    FImages [FCurrentImage].FGotPalette := FImages [FCurrentImage].FPalette <> 0;
    AssignFromGraphic (Self);
  end
  else
  begin
    FImages [FCurrentImage].FPalette := 0;
    FImages [FCurrentImage].FGotPalette := True
  end
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.SetPixelFormat                                     |
 |                                                                            |
 | Modify the icon so it uses a new pixel format.  If this pixel format has   |
 | <= 256 colours, apply an appropriate palette.  Could modify this to use    |
 | sophisticated color reduction, but at the moment it uses the 'default'     |
 | 16 color palete, and the 'netscape' 256 color one.                         |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.SetPixelFormat(const Value: TPixelFormat);
var
  newPalette : HPALETTE;
begin
  if value = PixelFormat then Exit;

  case value of
    pf1Bit : newPalette := SystemPalette2;
    pf4Bit : newPalette := SystemPalette16;
    pf8Bit : newPalette := SystemPalette256;
    else
      newPalette := 0
  end;

  FImages [FCurrentImage].FPixelFormat := Value;

  if FImages [FCurrentImage].FPalette <> 0 then
    DeleteObject (FImages [FCurrentImage].FPalette);

  if newPalette <> 0 then
  begin
    FImages [FCurrentImage].FPalette := CopyPalette (newPalette);
    FImages [FCurrentImage].FGotPalette := FImages [FCurrentImage].FPalette <> 0;
  end
  else
  begin
    FImages [FCurrentImage].FPalette := 0;
    FImages [FCurrentImage].FGotPalette := True
  end;

  AssignFromGraphic (self)
end;

procedure TExIconCursor.SetWidth (Value: Integer);
begin
  if Value = Width then Exit;

  Images [FCurrentImage].FWidth := Value;
  AssignFromGraphic (Self);
end;

{ TExIconImage }

destructor TExIconImage.Destroy;
begin
  FMemoryImage.Free;
  inherited                     // Which calls FreeHandle if necessary
end;

procedure TExIconImage.FreeHandle;
begin
  if FHandle <> 0 then
    DestroyIcon(FHandle);

  if FPalette <> 0 then
    DeleteObject (FPalette);
  FGotPalette := False;
  FPalette := 0;
  FHandle := 0;
end;

function TExIconImage.GetBitmapInfo: PBitmapInfo;
begin
  if Assigned (FMemoryImage) then
    if FIsIcon then
      result := PBitmapInfo (FMemoryImage.Memory)
    else
      result := PBitmapInfo (PChar (FMemoryImage.Memory) + sizeof (DWORD))
  else
    result := Nil
end;

function TExIconImage.GetBitmapInfoHeader: PBitmapInfoHeader;
begin
  result := PBitmapInfoHeader (GetBitmapInfo)
end;

function TExIconImage.GetMemoryImage: TCustomMemoryStream;
begin
  ImageNeeded;
  result := FMemoryImage
end;

(*----------------------------------------------------------------------*
 | TExIconImage.HandleNeeded                                            |
 |                                                                      |
 | In general, call this as little as possible.  I don't call it any-   |
 | where in this code - I draw the bitmaps directly, rather than using  |
 | DrawIconEx, etc.                                                     |
 |                                                                      |
 | CreateIconFromResourceEx is very unreliable with icons > 16 colours  |
 *----------------------------------------------------------------------*)
procedure TExIconImage.HandleNeeded;
var
  info : PBitmapInfoHeader;
  buff : PByte;
begin
  if Handle <> 0 then exit;
  if FMemoryImage = Nil then exit;

  if fPalette <> 0 then
  begin
    DeleteObject (fPalette);
    fPalette := 0;
    fGotPalette := False;
  end;

  if FMemoryImage.Size > sizeof (TBitmapInfoHeader) + 4 then
  begin
    info := GetBitmapInfoHeader;

// Aaaagh.  I don't believe I'm doing this.  For some reason you cant use 'FMemoryImage.Memory'
// directly in CreateIconFromResourceEx.  You have to copy it to a (GMEM_MOVEABLE) buffer first.
//
// And they call NT an operating system!

    GetMem (buff, FMemoryImage.Size);
    try
     FMemoryImage.Seek (0, soFromBeginning);
     Move (FMemoryImage.Memory^, buff^, FMemoryImage.Size);

      FHandle := CreateIconFromResourceEx (buff, FMemoryImage.Size, FisIcon, $00030000, info^.biWidth, info^.biHeight div 2, LR_DEFAULTCOLOR);
    finally
      FreeMem (Buff)
    end;

    if FHandle = 0 then raise
      EInvalidGraphic.Create (rstInvalidIcon);

    FWidth := info^.biWidth;
    FHeight := info^.biHeight div 2;
    FPixelFormat := GetBitmapInfoPixelFormat (info^);

    if info^.biBitCount <= 8 then
      FPalette := CreateDIBPalette (PBitmapInfo (info)^);

    fGotPalette := FPalette <> 0;
  end
end;

(*----------------------------------------------------------------------*
 | TExIconImage.ImageNeeded
 |                                                                      |
 *----------------------------------------------------------------------*)
procedure TExIconImage.ImageNeeded;
var
  Image: TMemoryStream;
  IconInfo: TIconInfo;
  MonoInfoSize, ColorInfoSize: DWORD;
  MonoBitsSize, ColorBitsSize: DWORD;
  MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
begin
  if FMemoryImage <> nil then Exit;
  if FHandle = 0 then
    raise EInvalidGraphic.Create (rstInvalidIcon);

  Image := TMemoryStream.Create;
  try
    GetIconInfo(Handle, IconInfo);
    try
      InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, pf1Bit);
      if IconInfo.hbmColor <> 0 then
        InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, PixelFormat);

      MonoInfo := nil;
      MonoBits := nil;
      ColorInfo := nil;
      ColorBits := nil;
      try
        MonoInfo := AllocMem(MonoInfoSize);
        MonoBits := AllocMem(MonoBitsSize);
        InternalGetDIB(IconInfo.hbmMask, 0, PBitmapInfo (MonoInfo), MonoBits^, pf1Bit);

        if IconInfo.hbmColor <> 0 then
        begin
          ColorInfo := AllocMem(ColorInfoSize);
          ColorBits := AllocMem(ColorBitsSize);

          InternalGetDIB(IconInfo.hbmColor, FPalette, PBitmapInfo (ColorInfo), ColorBits^, PixelFormat);
          with PBitmapInfoHeader(ColorInfo)^ do
            Inc(biHeight, biHeight); { color height includes mono bits }
        end;

        if (not FIsIcon) then
        begin
          Image.Write (IconInfo.xHotspot, SizeOf (iconInfo.xHotspot));
          Image.Write (IconInfo.yHotspot, SizeOf (iconInfo.yHotspot))
        end;

        if IconInfo.hbmColor <> 0 then
        begin
          Image.Write(ColorInfo^, ColorInfoSize);
          Image.Write(ColorBits^, ColorBitsSize)
        end
        else
          Image.Write(MonoInfo^, MonoInfoSize);

        Image.Write(MonoBits^, MonoBitsSize);
      finally
        FreeMem(ColorInfo, ColorInfoSize);
        FreeMem(ColorBits, ColorBitsSize);
        FreeMem(MonoInfo, MonoInfoSize);
        FreeMem(MonoBits, MonoBitsSize);
      end;
    finally
      if IconInfo.hbmColor <> 0 then
        DeleteObject(IconInfo.hbmColor);
      DeleteObject(IconInfo.hbmMask);
    end
  except
    Image.Free;
    raise;
  end;
  FMemoryImage := Image
end;

(*----------------------------------------------------------------------*
 | TExIconImage.PaletteNeeded
 |                                                                      |
 *----------------------------------------------------------------------*)
procedure TExIconImage.PaletteNeeded;
var
  info : PBitmapInfoHead