unitresourcegraphics.pas

East make Tray Icon in delphi

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.SetImage                                      |
 *----------------------------------------------------------------------*)
procedure TBitmapResourceDetails.SetImage(image : TPicture);
var
  s : TMemoryStream;
begin
  s := TMemoryStream.Create;
  try
    InternalSetImage (s, image);
    data.Clear;
    data.Write ((PChar (s.Memory) + sizeof (TBitmapFileHeader))^, s.Size - sizeof (TBitmapFileHeader));
  finally
    s.Free;
  end
end;

{ TIconGroupResourceDetails }

(*----------------------------------------------------------------------*
 | TIconGroupResourceDetails.GetBaseType                                |
 *----------------------------------------------------------------------*)
class function TIconGroupResourceDetails.GetBaseType: string;
begin
  result := IntToStr (Integer (RT_GROUP_ICON));
end;

{ TCursorGroupResourceDetails }

(*----------------------------------------------------------------------*
 | TCursorGroupResourceDetails.GetBaseType                              |
 *----------------------------------------------------------------------*)
class function TCursorGroupResourceDetails.GetBaseType: string;
begin
  result := IntToStr (Integer (RT_GROUP_CURSOR));
end;

{ TIconResourceDetails }

(*----------------------------------------------------------------------*
 | TIconResourceDetails.GetBaseType                                     |
 *----------------------------------------------------------------------*)
class function TIconResourceDetails.GetBaseType: string;
begin
  result := IntToStr (Integer (RT_ICON));
end;

{ TCursorResourceDetails }

(*----------------------------------------------------------------------*
 | TCursorResourceDetails.GetBaseType                                   |
 *----------------------------------------------------------------------*)
class function TCursorResourceDetails.GetBaseType: string;
begin
  result := IntToStr (Integer (RT_CURSOR));
end;

{ TGraphicsResourceDetails }


{ TIconCursorResourceDetails }

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.GetHeight                                 |
 *----------------------------------------------------------------------*)
function TIconCursorResourceDetails.GetHeight: Integer;
var
  infoHeader : PBitmapInfoHeader;
begin
  if self is TCursorResourceDetails then        // Not very 'OOP'.  Sorry
    infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
  else
    infoHeader := PBitmapInfoHeader (PChar (data.Memory));

  result := infoHeader.biHeight div 2
end;

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.GetImage                                  |
 *----------------------------------------------------------------------*)
procedure TIconCursorResourceDetails.GetImage(picture: TPicture);
var
  iconCursor : TExIconCursor;
  strm : TMemoryStream;
  hdr : TIconHeader;
  dirEntry : TIconDirEntry;
  infoHeader : PBitmapInfoHeader;
begin
  if data.Size = 0 then Exit;


  strm := Nil;
  if self is TCursorResourceDetails then
  begin
    hdr.wType := 2;
    infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD));
    iconCursor := TExCursor.Create
  end
  else
  begin
    hdr.wType := 1;
    infoHeader := PBitmapInfoHeader (PChar (data.Memory));
    iconCursor := TExIcon.Create
  end;

  try
    strm := TMemoryStream.Create;
    hdr.wReserved := 0;
    hdr.wCount := 1;

    strm.Write (hdr, sizeof (hdr));

    dirEntry.bWidth := infoHeader^.biWidth;
    dirEntry.bHeight := infoHeader^.biHeight div 2;
    dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^);
    dirEntry.bReserved := 0;

    dirEntry.wPlanes := infoHeader^.biPlanes;
    dirEntry.wBitCount := infoHeader^.biBitCount;

    dirEntry.dwBytesInRes := data.Size;
    dirEntry.dwImageOffset := sizeof (hdr) + sizeof (dirEntry);

    strm.Write (dirEntry, sizeof (dirEntry));
    strm.CopyFrom (data, 0);
    strm.Seek (0, soFromBeginning);

    iconcursor.LoadFromStream (strm);
    picture.Graphic := iconcursor
  finally
    strm.Free;
    iconcursor.Free
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.SetImage                                  |
 *----------------------------------------------------------------------*)
procedure TIconCursorResourceDetails.SetImage(image: TPicture);
var
  icon : TExIconCursor;
begin
  icon := TExIconCursor (image.graphic);
  data.Clear;
  data.CopyFrom (icon.Images [icon.CurrentImage].MemoryImage, 0);
end;


(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.GetPixelFormat                            |
 *----------------------------------------------------------------------*)
function TIconCursorResourceDetails.GetPixelFormat: TPixelFormat;
var
  infoHeader : PBitmapInfoHeader;
begin
  if self is TCursorResourceDetails then
    infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
  else
    infoHeader := PBitmapInfoHeader (PChar (data.Memory));

  result := GetBitmapInfoPixelFormat (infoHeader^);
end;

(*----------------------------------------------------------------------*
 | TIconCursorResourceDetails.GetWidth                                  |
 *----------------------------------------------------------------------*)
function TIconCursorResourceDetails.GetWidth: Integer;
var
  infoHeader : PBitmapInfoHeader;
begin
  if self is TCursorResourceDetails then
    infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
  else
    infoHeader := PBitmapInfoHeader (PChar (data.Memory));

  result := infoHeader.biWidth
end;

{ TIconCursorGroupResourceDetails }

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.BeforeDelete
 |                                                                      |
 *----------------------------------------------------------------------*)
procedure TIconCursorGroupResourceDetails.AddToGroup(
  details: TIconCursorResourceDetails);
var
  attributes : PResourceDirectory;
  infoHeader : PBitmapInfoHeader;
  cc : Integer;
begin
  data.Size := Data.Size + sizeof (TResourceDirectory);
  attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));

  Inc (Attributes, PIconHeader (data.Memory)^.wCount);

  attributes^.wNameOrdinal :=  StrToInt (details.ResourceName);
  attributes^.lBytesInRes := details.Data.Size;

  if details is TIconResourceDetails then
  begin
    infoHeader := PBitmapInfoHeader (PChar (details.data.Memory));
    attributes^.details.iconWidth := infoHeader^.biWidth;
    attributes^.details.iconHeight := infoHeader^.biHeight div 2;
    cc := GetBitmapInfoNumColors (infoHeader^);
    if cc < 256 then
      attributes^.details.iconColorCount := cc
    else
      attributes^.details.iconColorCount := 0;
    attributes^.details.iconReserved := 0
  end
  else
  begin
    infoHeader := PBitmapInfoHeader (PChar (details.data.Memory) + sizeof (DWORD));
    attributes^.details.cursorWidth := infoHeader^.biWidth;
    attributes^.details.cursorHeight := infoHeader^.biHeight div 2
  end;

  attributes^.wPlanes := infoHeader^.biPlanes;
  attributes^.wBitCount := infoHeader^.biBitCount;

  Inc (PIconHeader (data.Memory)^.wCount);
end;

procedure TIconCursorGroupResourceDetails.BeforeDelete;
begin
  fDeleting := True;
  try
    while ResourceCount > 0 do
      Parent.DeleteResource (Parent.IndexOfResource (ResourceDetails [0]));
  finally
    fDeleting := False
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.Contains                             |
 *----------------------------------------------------------------------*)
function TIconCursorGroupResourceDetails.Contains(
  details: TIconCursorResourceDetails): Boolean;
var
  i, id : Integer;
  attributes : PResourceDirectory;
begin
  Result := False;
  if ResourceNameToInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then
  begin
    attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
    id := ResourceNameToInt (details.ResourceName);

    for i := 0 to PIconHeader (Data.Memory)^.wCount - 1 do
      if attributes^.wNameOrdinal = id then
      begin
        Result := True;
        break
      end
      else
        Inc (attributes)
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.GetImage                             |
 *----------------------------------------------------------------------*)
procedure TIconCursorGroupResourceDetails.GetImage(picture: TPicture);
var
  i, hdrOffset, imgOffset : Integer;
  iconCursor : TExIconCursor;
  strm : TMemoryStream;
  hdr : TIconHeader;
  dirEntry : TIconDirEntry;
  pdirEntry : PIconDirEntry;
  infoHeader : PBitmapInfoHeader;
begin
  if data.Size = 0 then Exit;

  strm := Nil;
  if self is TCursorGroupResourceDetails then
  begin
    hdr.wType := 2;
    hdrOffset := SizeOf (DWORD);
    iconCursor := TExCursor.Create
  end
  else
  begin
    hdr.wType := 1;
    hdrOffset := 0;
    iconCursor := TExIcon.Create
  end;

  try
    strm := TMemoryStream.Create;
    hdr.wReserved := 0;
    hdr.wCount := ResourceCount;

    strm.Write (hdr, sizeof (hdr));

    for i := 0 to ResourceCount - 1 do
    begin
      infoHeader := PBitmapInfoHeader (PChar (ResourceDetails [i].Data.Memory) + hdrOffset);
      dirEntry.bWidth := infoHeader^.biWidth;
      dirEntry.bHeight := infoHeader^.biHeight div 2;
      dirEntry.wPlanes := infoHeader^.biPlanes;
      dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^);
      dirEntry.bReserved := 0;
      dirEntry.wBitCount := infoHeader^.biBitCount;
      dirEntry.dwBytesInRes := resourceDetails [i].data.Size;
      dirEntry.dwImageOffset := 0;

      strm.Write (dirEntry, sizeof (dirEntry));
    end;

    for i := 0 to ResourceCount - 1 do
    begin
      imgOffset := strm.Position;
      pDirEntry := PIconDirEntry (PChar (strm.Memory) + SizeOf (TIconHeader) + i * SizeOf (TIconDirEntry));
      pDirEntry^.dwImageOffset := imgOffset;

      strm.CopyFrom (ResourceDetails [i].Data, 0);
    end;

    if ResourceCount > 0 then
    begin
      strm.Seek (0, soFromBeginning);
      iconcursor.LoadFromStream (strm);
      picture.Graphic := iconcursor
    end
    else
      picture.Graphic := Nil
  finally
    strm.Free;
    iconcursor.Free
  end
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.GetResourceCount                     |
 *----------------------------------------------------------------------*)
function TIconCursorGroupResourceDetails.GetResourceCount: Integer;
begin
  result := PIconHeader (Data.Memory)^.wCount
end;

(*----------------------------------------------------------------------*
 | TIconCursorGroupResourceDetails.GetResourceDetails                   |
 *----------------------------------------------------------------------*)
function TIconCursorGroupResourceDetails.GetResourceDetails(
  idx: Integer): TIconCursorResourceDetails;
var
  i : Integer;
  res : TResourceDetails;
  attributes : PResourceDirectory;
  iconCursorResourceType : string;
begin
  result := Nil;
  attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
  Inc (attributes, idx);

  // DIFFERENCE (from Windows.pas) is 11.  It's the difference between a 'group
  // resource' and the resource itself.  They called it 'DIFFERENCE' to be annoying.

  iconCursorResourceType := IntToStr (ResourceNameToInt (ResourceType) - DIFFERENCE);
  for i := 0 to Parent.ResourceCount - 1 do