unitexicon.pas

灰鸽子VIP1.2经典源代码

  with FImages [FCurrentImage] do ImageNeeded;
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.LoadFromClipboardFormat                            |
 |                                                                            |
 | Ensure that a memory image exists for the current image.  Affects just the |
 | current image.                                                             |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.LoadFromClipboardFormat(AFormat: Word;
  AData: THandle; APalette: HPALETTE);
var
  Info : PBItmapInfo;
  image : TExIconImage;
  size : DWORD;
  InfoHeaderSize, ImageSize, monoSize : DWORD;
  mask : PByte;
begin
  size := GlobalSize (AData);
  if (size > 0) and (AFormat = CF_DIB) then
  begin

    image := TExIconImage.Create;
    image.FMemoryImage := TMemoryStream.Create;
    image.Reference;

    try
      info := PBitmapInfo (GlobalLock (AData));
      try
        image.FIsIcon := Images [FCurrentImage].FIsIcon;

        image.FWidth := info^.bmiHeader.biWidth;
        image.FHeight := info^.bmiHeader.biHeight;
        image.FPixelFormat := GetBitmapInfoPixelFormat (info^.bmiHeader);

        GetBitmapInfoSizes (info^.bmiHeader, InfoHeaderSize, ImageSize, False);
        monoSize := image.Width * image.FHeight div 8;

        if size = InfoHeaderSize + ImageSize + monoSize then
          image.FMemoryImage.Write (info^, InfoHeaderSize + ImageSize + monoSize)
        else
        begin
          image.FMemoryImage.Write (info^, InfoHeaderSize + ImageSize);
          GetMem (mask, monoSize);
          try
            FillChar (mask^, monoSize, $00);
            image.FMemoryImage.Write (mask^, monoSize)
          finally
            FreeMem (mask)
          end
        end;
        PBitmapInfo (image.FMemoryImage.Memory)^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2;
      finally
        GlobalUnlock (AData)
      end
    except
      image.Release;
      raise
    end;

    FImages [FCurrentImage].Release;
    FImages [FCurrentImage] := image
  end
end;

procedure TExIconCursor.LoadFromResourceId(Instance: THandle;
  ResID : Integer);
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.CreateFromID(Instance, ResID, RT_ICON);
  try
    ReadIcon(Instance, Stream, Stream.Size);
  finally
    Stream.Free;
  end;
end;

procedure TExIconCursor.LoadFromResourceName(Instance: THandle;
  const resName: string);
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.Create(Instance, ResName, RT_GROUP_ICON);
  try
    ReadIcon(Instance, Stream, Stream.Size);
  finally
    Stream.Free;
  end;
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.LoadFromStream                                     |
 |                                                                            |
 | Load all images from a stream                                              |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.LoadFromStream(Stream: TStream);
var
  hdr : TIconHeader;
  dirEntry : array of TIconDirEntry;
  i : Integer;
  p : PBitmapInfoHeader;
begin
  Stream.Read (hdr, SizeOf (hdr));

  if (self is TExIcon) <> (hdr.wType = 1) then
    raise EInvalidGraphic.Create (rstInvalidIcon);

  ReleaseImages;  // Get rid of existing images

  SetLength (fImages, hdr.wCount);
  SetLength (dirEntry, hdr.wCount);

                  // Create and initialize the ExIconImage classes and read
                  // the dirEntry structures from the stream.

  for i := 0 to hdr.wCount - 1 do
  begin
    fImages [i] := TExIconImage.Create;
    fImages [i].FIsIcon := self is TExIcon;
    fImages [i].FMemoryImage := TMemoryStream.Create;
    fImages [i].Reference;

    Stream.Read (dirEntry [i], SizeOf (TIconDirEntry));
    fImages [i].FWidth := dirEntry [i].bWidth;
    fImages [i].FHeight := dirEntry [i].bHeight;
  end;

                  // Read the icon images into their Memory streams
  for i := 0 to hdr.wCount - 1 do
  begin

    stream.Seek (dirEntry [i].dwImageOffset, soFromBeginning);

    fImages [i].FMemoryImage.CopyFrom (stream, dirEntry [i].dwBytesInRes);

    p := FImages [i].GetBitmapInfoHeader;
    p^.biSizeImage := 0;

    fImages [i].FPixelFormat := GetBitmapInfoPixelFormat (p^);
  end;

  FCurrentImage := 0;
  Changed(Self);
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.PaletteNeeded                                      |
 |                                                                            |
 | The palette is needed for the current image                                |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.PaletteNeeded;
begin
  FImages [FCurrentImage].PaletteNeeded;
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.ReleaseImages                                      |
 |                                                                            |
 | Release images for the icon.  Internal use only - you must set up at least |
 | one new image after calling it.                                            |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.ReadIcon(instance : THandle; stream: TCustomMemoryStream;
  Size: Integer);
var
  hdr : TIconHeader;
  resDir : TResourceDirectory;
  i : Integer;
  strm1 : TCustomMemoryStream;
  p : PBitmapInfoHEader;
begin
  stream.read (hdr, SizeOf (hdr));

  if (self is TExIcon) <> (hdr.wType = 1) then
    raise EInvalidGraphic.Create (rstInvalidIcon);

  ReleaseImages;  // Get rid of existing images

  SetLength (fImages, hdr.wCount);

  for i := 0 to hdr.wCount - 1 do
  begin
    stream.read (resDir, SizeOf (resDir));

    strm1 := TResourceStream.CreateFromID (Instance, resDir.wNameOrdinal, RT_ICON);
    try
      fImages [i] := TExIconImage.Create;
      fImages [i].FIsIcon := self is TExIcon;
      fImages [i].FMemoryImage := TMemoryStream.Create;
      fImages [i].Reference;

      if Self is TExIcon then
      begin
        fImages [i].FWidth := resDir.details.iconWidth;
        fImages [i].FHeight := resDir.details.iconHeight
      end
      else
      begin
        fImages [i].FWidth := resDir.details.cursorWidth;
        fImages [i].FHeight := resDir.details.cursorHeight
      end;

      fImages [i].FMemoryImage.CopyFrom (strm1, 0);
      p := FImages [i].GetBitmapInfoHeader;
      p^.biSizeImage := 0;

      fImages [i].FPixelFormat := GetBitmapInfoPixelFormat (p^);
    finally
      strm1.Free
    end
  end;

  FCurrentImage := 0;
  Changed(Self);
end;

function TExIconCursor.ReleaseHandle: HICON;
begin
  HandleNeeded;
  if FImages [fCurrentImage].RefCount > 1 then
    Result := CopyIcon (FImages [fCurrentImage].FHandle) else
  begin
    Result := FImages [fCurrentImage].FHandle;
    FImages [fCurrentImage].fHandle := 0
  end
end;

procedure TExIconCursor.ReleaseImages;
var
  i : Integer;
begin
  for i := 0 to Length (fImages) - 1 do
    fImages [i].Release;

  SetLength (fImages, 0)
end;

(*----------------------------------------------------------------------*
 | TExIconCursor.SaveImageToFile
 |                                                                      |
 *----------------------------------------------------------------------*)
procedure TExIconCursor.SaveImageToFile(const FileName: string);
// Save current image to 'ico' file
var
  hdr : TIconHeader;
  dirEntry : TIconDirEntry;
  image : TExIconImage;
  dirSize : Integer;
  stream : TStream;
begin
  hdr.wReserved := 0;
  if not (self is TExCursor) then
    hdr.wType := 1
  else
    hdr.wType := 2;
  hdr.wCount := 1;

  stream := TFileStream.Create (FileName, fmCreate);
  try
    Stream.Write (hdr, SizeOf (hdr));
    dirSize := sizeof (dirEntry) + sizeof (hdr);

    ImageNeeded;
    image := Images [CurrentImage];

    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;

    if hdr.wType = 2 then
    begin
      dirEntry.wPlanes := LOWORD (TExCursor (Self).Hotspot);
      dirEntry.wBitCount := HIWORD (TExCursor (Self).Hotspot)
    end
    else
      dirEntry.wPlanes := 1;
    dirEntry.dwBytesInRes := image.FMemoryImage.Size;
    if hdr.wType = 2 then
    begin
      image.FMemoryImage.Seek (SizeOf (DWORD), soFromBeginning);
      Dec (dirEntry.dwBytesInRes, SizeOf (DWORD))
    end
    else
      image.FMemoryImage.Seek (0, soFromBeginning);

    dirEntry.dwImageOffset := dirSize;
    Stream.Write (dirEntry, SizeOf (dirEntry));
    Stream.CopyFrom (image.FMemoryImage, image.FMemoryImage.Size - image.FMemoryImage.Position);

  finally
    stream.Free
  end
end;

(*----------------------------------------------------------------------------*
 | procedure TExIconCursor.SaveToClipboardFormat                              |
 |                                                                            |
 | Saves the image on the clipboard as a DDB                                  |
 *----------------------------------------------------------------------------*)
procedure TExIconCursor.SaveToClipboardFormat(var AFormat: Word;
  var AData: THandle; var APalette: HPALETTE);
var
  info : PBitmapInfo;
  InfoHeaderSize, ImageSize, monoSize : DWORD;
  buf : PChar;
begin
  AFormat := CF_DIB;
  ImageNeeded;
  info := Images [fCurrentImage].GetBitmapInfo;
  info^.bmiHeader.biHeight := info^.bmiHeader.biHeight div 2;
  try
    GetBitmapInfoSizes (info^.bmiHeader, InfoHeaderSize, ImageSize, False);
    monoSize := Width * Height div 8;

    AData := GlobalAlloc (GMEM_DDESHARE, InfoHeaderSize + ImageSize + monoSize);
    buf := GlobalLock (AData);
    try
      Move (info^, buf^, InfoHeaderSize + ImageSize + monoSize);
    finally
      GlobalUnlock (AData)
    end;

    APalette := 0;  // Don't need the palette, cause we've copied the DIB
  finally
    info^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2
  end;
end;

procedure TExIconCursor.SaveToStream(Stream: TStream);
var
  hdr : TIconHeader;
  dirEntry : TIconDirEntry;
  image : TExIconImage;
  i, dirSize, offset : Integer;
  oldCurrentImage : Integer;
begin
  hdr.wReserved := 0;
  if not (self is TExCursor) then
    hdr.wType := 1
  else
    hdr.wType := 2;
  hdr.wCount := ImageCount;

  Stream.Write (hdr, SizeOf (hdr));
  dirSize := ImageCount * sizeof (dirEntry) + sizeof (hdr);

  oldCurrentImage := FCurrentImage;
  try
    offset := 0;