jvimagelist.pas

East make Tray Icon in delphi

procedure TJvImageList.SlicePictureToImageList;
var
  Bmp: TBitmap;
  OwnBitmap: Boolean;
  MaskColor: TColor;
begin
  BeginUpdate;
  try
    Clear;
    if FPicture.Graphic = nil then
      Exit;

    OwnBitmap := False;
    if FPicture.Graphic is TBitmap then
      Bmp := FPicture.Bitmap
    else
    begin
      OwnBitmap := True;
      Bmp := TBitmap.Create;
      Bmp.Canvas.Brush.Color := FTransparentColor;
      Bmp.Width := FPicture.Width;
      Bmp.Height := FPicture.Height;
      Bmp.Canvas.Draw(0, 0, FPicture.Graphic);
    end;
    try
      if TransparentMode = tmNone then
        MaskColor := clNone
      else
        MaskColor := TransparentColor;

      LoadImageListFromBitmap(Self, Bmp, MaskColor, TransparentMode = tmAuto);
    finally
      if OwnBitmap then
        Bmp.Free;
    end;
  finally
    EndUpdate;
  end;
end;

procedure TJvImageList.ResourceIdsToImageList;
var
  Bmp: TBitmap;
  ResStream: TResourceStream;
  i: Integer;
  MaskColor: TColor;
begin
  BeginUpdate;
  try
    Clear;
    if ResourceIds.Count = 0 then
      Exit;

    Bmp := TBitmap.Create;
    try
      for i := 0 to ResourceIds.Count - 1 do
      begin
        if Trim(ResourceIds[i]) <> '' then
        try
         // load resource
          ResStream := nil;
          try
            try
              ResStream := TResourceStream.Create(HInstance, ResourceIds[i], RT_BITMAP);
            except
              ResStream := nil;
            end;
            if ResStream <> nil then
              Bmp.LoadFromResourceName(HInstance, ResourceIds[i])
            else
            begin
              ResStream := TResourceStream.Create(HInstance, ResourceIds[i], RT_RCDATA);
              Bmp.LoadFromStream(ResStream);
            end;
          finally
            ResStream.Free;
          end;

         // add bitmap
          if not Bmp.Empty and (Bmp.Width > 0) and (Bmp.Height > 0) then
          begin
            case TransparentMode of
              tmNone:
                MaskColor := clNone;
              tmColor:
                MaskColor := TransparentColor;
              tmAuto:
                MaskColor := Bmp.Canvas.Pixels[0, Bmp.Height - 1];
            else
              MaskColor := clNone; // make the compiler happy
            end;
            AddMasked(Bmp, MaskColor);
          end;
        except
          // ignore exception
        end;
      end;
    finally
      Bmp.Free;
    end;
  finally
    EndUpdate;
  end;
end;

type
  TComponentAccessProtected = class(TComponent);
  TDefineProperties = procedure(Self: TComponent; Filer: TFiler);

procedure TJvImageList.DefineProperties(Filer: TFiler);
begin
  Inc(FUpdateLock); // no BeginUpdate/EndUpdate here
  try
    if (Filer is TWriter) then
      DoLoadFromFile; // update Picture.Graphic if a filename is specified

    if (Filer is TWriter) and
      (((FMode = imPicture) and (FPicture.Graphic <> nil) and (not FPicture.Graphic.Empty)) or
      ((FMode = imResourceIds) and (FResourceIds.Count > 0)) or
      ((FMode = imItemList) and (FItems.Count > 0))) then
      TDefineProperties(@TComponentAccessProtected.DefineProperties)(Self, Filer)
    else
      inherited DefineProperties(Filer);
  finally
    Dec(FUpdateLock);
  end;
end;

{$IFDEF VCL}
procedure TJvImageList.SetPixelFormat(const Value: TPixelFormat);
var
  ImgList: TJvImageList;
begin
  if (Value <> FPixelFormat) and not (Value in [pf1bit, pfCustom]) then
  begin
    if HandleAllocated then
    begin
      BeginUpdate;
      try
       // convert image list
        ImgList := TJvImageList.CreateSize(Width, Height);
        try
          ImgList.Assign(Self); // copy imagelist with old pixelformat
          FPixelFormat := Value; // set new pixelformat
          CreateImageList; // create new image list handle
          AddImages(ImgList);
        finally
          ImgList.Free;
        end;
      finally
        EndUpdate;
      end;
    end
    else
      FPixelFormat := Value;
  end;
end;
{$ENDIF VCL}

procedure TJvImageList.SetItems(AItems: TJvImageListItems);
begin
  Clear;
  FItems.Assign(AItems);
end;

procedure TJvImageList.AddItem(ABitmap: TBitmap; ATransparentColor: TColor);
var
  BitmapItem: TJvImageListItem;
begin
  if Mode <> imItemList then
    Clear;
  Mode := imItemList;
  BitmapItem := FItems.Add;
  BitmapItem.Kind := ikInlineBitmap;
  BitmapItem.Bitmap.Assign(ABitmap);
  BitmapItem.TransparentColor := ATransparentColor;
end;

procedure TJvImageList.AddItem(const AResourceName: string; ATransparentColor: TColor);
var
  ResourceItem: TJvImageListItem;
begin
  if Mode <> imItemList then
    Clear;
  Mode := imItemList;
  ResourceItem := FItems.Add;
  ResourceItem.Kind := ikResourceBitmap;
  ResourceItem.ResourceName := AResourceName;
  ResourceItem.TransparentColor := ATransparentColor;
end;

procedure TJvImageList.DeleteItem(AIndex: Integer);
begin
  if Mode = imItemList then
    FItems.Delete(AIndex)
  else
    ItemListError;
end;

procedure TJvImageList.ClearItems;
begin
  if Mode = imItemList then
  begin
    Clear;
    FItems.Clear;
  end
  else
    ItemListError;
end;

function TJvImageList.GetItemInfoStr(AIndex: Integer): string;
begin
  Result := '';
  if Mode = imItemList then
    Result := FItems[AIndex].DisplayName
  else
    ItemListError;
end;

procedure TJvImageList.SetResourceIds(Value: TStrings);
begin
  if (Value <> nil) and (Value <> FResourceIds) then
    FResourceIds.Assign(Value);
end;

procedure TJvImageList.SetMode(const Value: TJvImageListMode);
begin
  if Value <> FMode then
  begin
    FMode := Value;
    UpdateImageList;
  end;
end;

procedure TJvImageList.UpdateImageList;
begin
  case FMode of
    imClassic:
      ; // do nothing
    imPicture:
      SlicePictureToImageList;
    imResourceIds:
      ResourceIdsToImageList;
    imItemList:
      ; // do nothing
  end;
end;

{$IFDEF VCL}

procedure TJvImageList.SetInternalHandle(Value: THandle);
begin
  if not HandleAllocated or (Handle <> Value) then
  begin
    Inc(FUpdateLock); // no BeginUpdate/EndUpdate here
    try
      Handle := Value;
    finally
      Dec(FUpdateLock);
    end;
  end;
end;

procedure TJvImageList.HandleNeeded;
begin
  if not HandleAllocated then
    CreateImageList;
end;

procedure TJvImageList.CreateImageList;
begin
  FHandle := CreateImageListHandle(Width, Height, FPixelFormat, Masked, AllocBy);
  if not HandleAllocated then
    raise EInvalidOperation.CreateRes(@SInvalidImageList);
  if BkColor <> clNone then
    BkColor := BkColor;
end;

procedure TJvImageList.DrawIndirect(ImageListDrawParams: TImageListDrawParams);
begin
  ImageListDrawParams.cbSize := SizeOf(ImageListDrawParams);
  ImageListDrawParams.himl := Handle;
  ImageList_DrawIndirect(@ImageListDrawParams);
end;

function TJvImageList.Merge(Index1: Integer; ImageList: TImageList;
  Index2, dx, dy: Integer): TImageList;
var
  h: THandle;
begin
  h := ImageList_Merge(Handle, Index1, ImageList.Handle, Index2, dx, dy);
  if h = 0 then
    Result := nil
  else
  begin
    Result := TJvImageList.Create(nil);
    Result.Handle := h;
  end;
end;
{$ENDIF VCL}

{$IFDEF VisualCLX}
procedure TJvImageList.GetIcon(Index: Integer; Ico: TIcon);
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    GetBitmap(Index, Bmp);
    Ico.Assign(Bmp);
  finally
    Bmp.Free;
  end;
end;
{$ENDIF VisualCLX}



procedure TJvImageList.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TJvImageList.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

{$IFDEF VCL}

procedure TJvImageList.Initialize;
begin
  inherited Initialize;
  InitializeImageList;
end;

procedure TJvImageList.LoadFromStream(Stream: TStream);
var
  Adapter: IStream;
begin
  Adapter := TStreamAdapter.Create(Stream);
  Handle := ImageList_Read(Adapter);
end;

procedure TJvImageList.SaveToStream(Stream: TStream);
type
  TWriteExProc = function(himl: HIMAGELIST; Flags: Cardinal; Stream: IStream): HResult; stdcall;
const
  ILP_NORMAL = 0;
  ILP_DOWNLEVEL = 1;
var
  Adapter: IStream;
  ImageList_WriteEx: TWriteExProc;
begin
  Adapter := TStreamAdapter.Create(Stream);
  if PixelFormat <> pf32bit then // 32 Bit is only supported by CommCtrls 6.0
  begin
    ImageList_WriteEx := GetProcAddress(GetModuleHandle('comctl32.dll'), 'ImageList_WriteEx');
    if Assigned(ImageList_WriteEx) then
    begin
      // write down
      ImageList_WriteEx(Handle, ILP_DOWNLEVEL, Adapter);
      Exit;
    end;
  end;
  ImageList_Write(Handle, Adapter);
end;

{$ENDIF VCL}

{$IFDEF VisualCLX}

procedure TJvImageList.Initialize(const AWidth, AHeight: Integer);
begin
  inherited Initialize(AWidth, AHeight);
  InitializeImageList;
end;

procedure TJvImageList.LoadFromStream(Stream: TStream);
begin
  ReadData(Stream);
end;

procedure TJvImageList.SaveToStream(Stream: TStream);
begin
  WriteData(Stream);
end;

{$ENDIF VisualCLX}

procedure TJvImageList.ItemListError;
begin
  raise EJvImageListError.CreateResFmt(@RsEWrongImageListMode, ['imItemList']);
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  {$IFDEF VCL}
  UninstallHandleNeededHook;
  {$ENDIF VCL}
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.