unitresourcegraphics.pas

East make Tray Icon in delphi

  begin
    res := Parent.ResourceDetails [i];
    if (res is TIconCursorResourceDetails) and (iconCursorResourceType = res.ResourceType) and (attributes.wNameOrdinal = ResourceNameToInt (res.ResourceName)) then
    begin
      result := TIconCursorResourceDetails (res);
      break
    end
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.InitNew                              |
 *----------------------------------------------------------------------*)
procedure TIconCursorGroupResourceDetails.InitNew;
var
  imageResource : TIconCursorResourceDetails;
  iconHeader : TIconHeader;
  dir : TResourceDirectory;
  nm : string;

begin
  iconHeader.wCount := 1;
  iconHeader.wReserved := 0;

  if Self is TCursorGroupResourceDetails then
  begin
    iconHeader.wType := 2;
    nm := Parent.GetUniqueResourceName (TCursorResourceDetails.GetBaseType);
    imageResource := TCursorResourceDetails.CreateNew (Parent, ResourceLanguage, nm)
  end
  else
  begin
    iconHeader.wType := 1;
    nm := Parent.GetUniqueResourceName (TIconResourceDetails.GetBaseType);
    imageResource := TIconResourceDetails.CreateNew (Parent, ResourceLanguage, nm)
  end;

  data.Write (iconHeader, SizeOf (iconHeader));

  if Self is TIconGroupResourceDetails then
  begin
    dir.details.iconWidth := DefaultIconCursorWidth;
    dir.details.iconHeight := DefaultIconCursorHeight;
    dir.details.iconColorCount := GetPixelFormatNumColors (DefaultIconCursorPixelFormat);
    dir.details.iconReserved := 0
  end
  else
  begin
    dir.details.cursorWidth := DefaultIconCursorWidth;
    dir.details.cursorHeight := DefaultIconCursorHeight
  end;

  dir.wPlanes := 1;
  dir.wBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat);
  dir.lBytesInRes := imageResource.Data.Size;
  dir.wNameOrdinal := ResourceNametoInt (imageResource.ResourceName);

  data.Write (dir, SizeOf (dir));
end;

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.BeforeDelete                              |
 |                                                                      |
 | If we're deleting an icon/curor resource, remove its reference from  |
 | the icon/cursor group resource.                                      |
 *----------------------------------------------------------------------*)
procedure TIconCursorResourceDetails.BeforeDelete;
var
  i : Integer;
  details : TResourceDetails;
  resGroup : TIconCursorGroupResourceDetails;
begin
  for i := 0 to Parent.ResourceCount - 1 do
  begin
    details := Parent.ResourceDetails [i];
    if (details.ResourceType = IntToStr (ResourceNameToInt (ResourceType) + DIFFERENCE)) then
    begin
      resGroup := details as TIconCursorGroupResourceDetails;
      if resGroup.Contains (Self) then
      begin
        resGroup.RemoveFromGroup (Self);
        break
      end
    end
  end
end;

procedure TIconCursorGroupResourceDetails.LoadImage(
  const FileName: string);
var
  img : TExIconCursor;
  hdr : TIconHeader;
  i : Integer;
  dirEntry : TResourceDirectory;
  res : TIconCursorResourceDetails;
  resTp : string;
begin
  BeforeDelete;         // Make source there are no existing image resources

  if Self is TIconGroupResourceDetails then
  begin
    hdr.wType := 1;
    img := TExIcon.Create;
    resTp := TIconResourceDetails.GetBaseType;
  end
  else
  begin
    hdr.wType := 2;
    img := TExCursor.Create;
    resTp := TCursorResourceDetails.GetBaseType;
  end;

  img.LoadFromFile (FileName);

  hdr.wReserved := 0;
  hdr.wCount := img.ImageCount;

  data.Clear;

  data.Write (hdr, SizeOf (hdr));

  for i := 0 to img.ImageCount - 1 do
  begin
    if hdr.wType = 1 then
    begin
      dirEntry.details.iconWidth := img.Images [i].FWidth;
      dirEntry.details.iconHeight := img.Images [i].FHeight;
      dirEntry.details.iconColorCount := GetPixelFormatNumColors (img.Images [i].FPixelFormat);
      dirEntry.details.iconReserved := 0
    end
    else
    begin
      dirEntry.details.cursorWidth := img.Images [i].FWidth;
      dirEntry.details.cursorHeight := img.Images [i].FHeight;
    end;

    dirEntry.wPlanes := 1;
    dirEntry.wBitCount := GetPixelFormatBitCount (img.Images [i].FPixelFormat);

    dirEntry.lBytesInRes := img.Images [i].FMemoryImage.Size;

    if hdr.wType = 1 then
      res := TIconResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory)
    else
      res := TCursorResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory);
    Parent.AddResource (res);
    dirEntry.wNameOrdinal := ResourceNameToInt (res.ResourceName);

    data.Write (dirEntry, SizeOf (dirEntry));
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.RemoveFromGroup                      |
 *----------------------------------------------------------------------*)
procedure TIconCursorGroupResourceDetails.RemoveFromGroup(
  details: TIconCursorResourceDetails);
var
  i, id, count : Integer;
  attributes, ap : PResourceDirectory;
begin
  if ResourceNametoInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then
  begin
    attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
    id := ResourceNametoInt (details.ResourceName);

    Count := PIconHeader (Data.Memory)^.wCount;

    for i := 0 to Count - 1 do
      if attributes^.wNameOrdinal = id then
      begin
        if i < Count - 1 then
        begin
          ap := Attributes;
          Inc (ap);
          Move (ap^, Attributes^, SizeOf (TResourceDirectory) * (Count - i - 1));
        end;

        Data.Size := data.Size - SizeOf (TResourceDirectory);
        PIconHeader (Data.Memory)^.wCount := Count - 1;
        if (Count = 1) and not fDeleting then
          Parent.DeleteResource (Parent.IndexOfResource (Self));
        break
      end
      else
        Inc (attributes)
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.InitNew                                   |
 *----------------------------------------------------------------------*)
procedure TIconCursorResourceDetails.InitNew;
var
  hdr : TBitmapInfoHeader;
  cImageSize : DWORD;
  pal : HPALETTE;
  entries : PPALETTEENTRY;
  w : DWORD;
  p : PChar;

begin
  if Self is TCursorResourceDetails then
    Data.Write (DefaultCursorHotspot, SizeOf (DefaultCursorHotspot));

  hdr.biSize := SizeOf (hdr);
  hdr.biWidth := DefaultIconCursorWidth;
  hdr.biHeight := DefaultIconCursorHeight * 2;
  hdr.biPlanes := 1;
  hdr.biBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat);

  if DefaultIconCursorPixelFormat = pf16Bit then
    hdr.biCompression := BI_BITFIELDS
  else
    hdr.biCompression := BI_RGB;

  hdr.biSizeImage := 0; // See note in unitExIcon

  hdr.biXPelsPerMeter := 0;
  hdr.biYPelsPerMeter := 0;

  hdr.biClrUsed := GetPixelFormatNumColors (DefaultIconCursorPixelFormat);
  hdr.biClrImportant := hdr.biClrUsed;

  Data.Write (hdr, SizeOf (hdr));

  pal := 0;
  case DefaultIconCursorPixelFormat of
    pf1Bit : pal := SystemPalette2;
    pf4Bit : pal := SystemPalette16;
    pf8Bit : pal := SystemPalette256
  end;

  entries := Nil;
  try
    if pal > 0 then
    begin
      GetMem (entries, hdr.biClrUsed * sizeof (PALETTEENTRY));
      GetPaletteEntries (pal, 0, hdr.biClrUsed, entries^);

      data.Write (entries^, hdr.biClrUsed * SizeOf (PALETTEENTRY))
    end
    else
      if hdr.biCompression = BI_BITFIELDS then
      begin { 5,6,5 bitfield }
        w := $0f800;  // 1111 1000 0000 0000  5 bit R mask
        data.Write (w, SizeOf (w));
        w := $07e0;   // 0000 0111 1110 0000  6 bit G mask
        data.Write (w, SizeOf (w));
        w := $001f;   // 0000 0000 0001 1111  5 bit B mask
        data.Write (w, SizeOf (w))
      end

  finally
    ReallocMem (entries, 0)
  end;

  // Write dummy image
  cImageSize := BytesPerScanLine (hdr.biWidth, hdr.biBitCount, 32) * DefaultIconCursorHeight;
  p := AllocMem (cImageSize);
  try
    data.Write (p^, cImageSize);
  finally
    ReallocMem (p, 0)
  end;

  // Write dummy mask
  cImageSize := DefaultIconCursorHeight * DefaultIconCursorWidth div 8;

  GetMem (p, cImageSize);
  FillChar (p^, cImageSize, $ff);

  try
    data.Write (p^, cImageSize);
  finally
    ReallocMem (p, 0)
  end;
end;

{ TDIBResourceDetails }

class function TDIBResourceDetails.GetBaseType: string;
begin
  Result := 'DIB';
end;

procedure TDIBResourceDetails.GetImage(picture: TPicture);
begin
  InternalGetImage (data, Picture);
end;

procedure TDIBResourceDetails.InitNew;
var
  hdr : TBitmapFileHeader;
begin
  hdr.bfType := $4d42;
  hdr.bfSize := SizeOf (TBitmapFileHeader) + SizeOf (TBitmapInfoHeader);
  hdr.bfReserved1 := 0;
  hdr.bfReserved2 := 0;
  hdr.bfOffBits := hdr.bfSize;
  data.Write (hdr, SizeOf (hdr));

  inherited;
end;

procedure TDIBResourceDetails.SetImage(image: TPicture);
begin
  InternalSetImage (data, image);
end;

class function TDIBResourceDetails.SupportsData(Size: Integer;
  data: Pointer): Boolean;
var
  p : PBitmapFileHeader;
  hdrSize : DWORD;
begin
  Result := False;
  p := PBitmapFileHeader (data);
  if (p^.bfType = $4d42) and (p^.bfReserved1 = 0) and (p^.bfReserved2 = 0) then
  begin
    hdrSize := PDWORD (PChar (data) + SizeOf (TBitmapFileHeader))^;

    case hdrSize of
      SizeOf (TBitmapInfoHeader) : Result := True;
      SizeOf (TBitmapV4Header) : Result := True;
      SizeOf (TBitmapV5Header) : Result := True
    end
  end
end;

{ TGraphicsResourceDetails }

procedure TGraphicsResourceDetails.SetImage(image: TPicture);
begin
  data.Clear;
  image.Graphic.SaveToStream (data);
end;

initialization
  TPicture.RegisterFileFormat ('ICO', rstIcons, TExIcon);
  TPicture.RegisterFileFormat ('CUR', rstCursors, TExCursor);
  TPicture.UnregisterGraphicClass (TIcon);


  RegisterResourceDetails (TBitmapResourceDetails);
  RegisterResourceDetails (TDIBResourceDetails);
  RegisterResourceDetails (TIconGroupResourceDetails);
  RegisterResourceDetails (TCursorGroupResourceDetails);
  RegisterResourceDetails (TIconResourceDetails);
  RegisterResourceDetails (TCursorResourceDetails);
finalization
  TPicture.UnregisterGraphicClass (TExIcon);
  TPicture.UnregisterGraphicClass (TExCursor);
  TPicture.RegisterFileFormat ('ICO', 'Icon', TIcon);
  UnregisterResourceDetails (TCursorResourceDetails);
  UnregisterResourceDetails (TIconResourceDetails);
  UnregisterResourceDetails (TCursorGroupResourceDetails);
  UnregisterResourceDetails (TIconGroupResourceDetails);
  UnregisterResourceDetails (TDIBResourceDetails);
  UnregisterResourceDetails (TBitmapResourceDetails);
end.