imglist.pas

这是不可多得的源代码

  if (Image <> nil) and HandleAllocated then
    Image.Handle := ImageList_GetIcon(Handle, Index,
      DrawingStyles[ADrawingStyle] or Images[AImageType]);
end;

function TCustomImageList.GetCount: Integer;
begin
  if HandleAllocated then Result := ImageList_GetImageCount(Handle)
  else Result := 0;
end;

procedure TCustomImageList.Replace(Index: Integer; Image, Mask: TBitmap);
var
  ImageDDB, MaskDDB: TBitmap;
begin
  ImageDDB := TBitmap.Create;
  try
    MaskDDB := TBitmap.Create;
    try
      if HandleAllocated and not ImageList_Replace(Handle, Index,
        GetImageHandle(Image, ImageDDB), GetImageHandle(Mask, MaskDDB)) then
          raise EInvalidOperation.Create(SReplaceImage);
    finally
      MaskDDB.Free;
    end;
  finally
    ImageDDB.Free;
  end;
  Change;
end;

procedure TCustomImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
var
  TempIndex: Integer;
  Image, Mask: TBitmap;
begin
  if HandleAllocated then
  begin
    CheckImage(NewImage);
    TempIndex := AddMasked(NewImage, MaskColor);
    if TempIndex <> -1 then
    try
      Image := TBitmap.Create;
      try
        with Image do
        begin
          Height := FHeight;
          Width := FWidth;
        end;
        Mask := TBitmap.Create;
        try
          with Mask do
          begin
            Monochrome := True;
            Height := FHeight;
            Width := FWidth;
          end;
          ImageList_Draw(Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL);
          ImageList_Draw(Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_MASK);
          if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then
            raise EInvalidOperation.Create(SReplaceImage);
        finally
          Mask.Free;
        end;
      finally
        Image.Free;
      end;
    finally
      Delete(TempIndex);
    end
    else raise EInvalidOperation.Create(SReplaceImage);
  end;
  Change;
end;

procedure TCustomImageList.ReplaceIcon(Index: Integer; Image: TIcon);
begin
  if HandleAllocated then
    if Image = nil then Replace(Index, nil, nil)
    else begin
      CheckImage(Image);
      if ImageList_ReplaceIcon(Handle, Index, Image.Handle) = -1 then
        raise EInvalidOperation.Create(SReplaceImage);
    end;
  Change;
end;

procedure TCustomImageList.Delete(Index: Integer);
begin
  if Index >= Count then raise EInvalidOperation.Create(SImageIndexError);
  if HandleAllocated then ImageList_Remove(Handle, Index);
  Change;
end;

procedure TCustomImageList.Clear;
begin
  Delete(-1);
end;

procedure TCustomImageList.SetBkColor(Value: TColor);
begin
  if HandleAllocated then ImageList_SetBkColor(FHandle, GetRGBColor(Value))
  else FBkColor := Value;                   
  Change;
end;

function TCustomImageList.GetBkColor: TColor;
begin
  if HandleAllocated then Result := GetColor(ImageList_GetBkColor(Handle))
  else Result := FBkColor;
end;

procedure TCustomImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
  Style: Cardinal; Enabled: Boolean);
const
  ROP_DSPDxax = $00E20746;
var
  R: TRect;
  DestDC, SrcDC: HDC;
begin
  if HandleAllocated then
  begin
    if Enabled then
      ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
        GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
    else
    begin
      if FMonoBitmap = nil then
      begin
        FMonoBitmap := TBitmap.Create;
        with FMonoBitmap do
        begin
          Monochrome := True;
          Width := Self.Width;
          Height := Self.Height;
        end;
      end;
      { Store masked version of image temporarily in FBitmap }
      FMonoBitmap.Canvas.Brush.Color := clWhite;
      FMonoBitmap.Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
      ImageList_DrawEx(Handle, Index, FMonoBitmap.Canvas.Handle, 0,0,0,0,
        CLR_NONE, 0, ILD_NORMAL);
      R := Rect(X, Y, X+Width, Y+Height);
      SrcDC := FMonoBitmap.Canvas.Handle;
      { Convert Black to clBtnHighlight }
      Canvas.Brush.Color := clBtnHighlight;
      DestDC := Canvas.Handle;
      Windows.SetTextColor(DestDC, clWhite);
      Windows.SetBkColor(DestDC, clBlack);
      BitBlt(DestDC, X+1, Y+1, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
      { Convert Black to clBtnShadow }
      Canvas.Brush.Color := clBtnShadow;
      DestDC := Canvas.Handle;
      Windows.SetTextColor(DestDC, clWhite);
      Windows.SetBkColor(DestDC, clBlack);
      BitBlt(DestDC, X, Y, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
    end;
  end;
end;

procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer;
  Enabled: Boolean);
begin
  Draw(Canvas, X, Y, Index, DrawingStyle, ImageType, Enabled);
end;

procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer;
  ADrawingStyle: TDrawingStyle; AImageType: TImageType; Enabled: Boolean);
begin
  if HandleAllocated then
    DoDraw(Index, Canvas, X, Y, DrawingStyles[ADrawingStyle] or
      Images[AImageType], Enabled);
end;

procedure TCustomImageList.DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  ImageIndex: Integer; Overlay: TOverlay; Enabled: Boolean);
begin
  DrawOverlay(Canvas, X, Y, ImageIndex, Overlay, dsNormal, itImage, Enabled);
end;

procedure TCustomImageList.DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  ImageIndex: Integer; Overlay: TOverlay; ADrawingStyle: TDrawingStyle;
  AImageType: TImageType; Enabled: Boolean);
var
  Index: Integer;
begin
  if HandleAllocated then
  begin
    Index := IndexToOverlayMask(Overlay + 1);
    DoDraw(ImageIndex, Canvas, X, Y, DrawingStyles[ADrawingStyle] or
      Images[AImageType] or ILD_OVERLAYMASK and Index, Enabled);
  end;
end;

function TCustomImageList.Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
begin
  if HandleAllocated then
    Result := ImageList_SetOverlayImage(Handle, ImageIndex, Overlay + 1)
  else Result := False;
end;

procedure TCustomImageList.CopyImages(Value: HImageList; Index: Integer = -1);
var
  I: Integer;
  Image, Mask: TBitmap;
  ARect: TRect;
begin
  ARect := Rect(0, 0, Width, Height);
  BeginUpdate;
  try
    Image := TBitmap.Create;
    try
      with Image do
      begin
        Height := FHeight;
        Width := FWidth;
      end;
      Mask := TBitmap.Create;
      try
        with Mask do
        begin
          Monochrome := True;
          Height := FHeight;
          Width := FWidth;
        end;
        for I := 0 to ImageList_GetImageCount(Value) - 1 do
          if (Index = -1) or (Index = I) then
          begin
            with Image.Canvas do
            begin
              FillRect(ARect);
              ImageList_Draw(Value, I, Handle, 0, 0, ILD_NORMAL);
            end;
            with Mask.Canvas do
            begin
              FillRect(ARect);
              ImageList_Draw(Value, I, Handle, 0, 0, ILD_MASK);
            end;
            Add(Image, Mask);
          end;
      finally
        Mask.Free;
      end;
    finally
      Image.Free;
    end;
  finally
    EndUpdate;
  end;
end;

procedure TCustomImageList.GetImages(Index: Integer; Image, Mask: TBitmap);
var
  R: TRect;
begin
  R := Rect(0, 0, Width, Height);
  with Image.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(R);
    ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_NORMAL);
  end;
  with Mask.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(R);
    ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_MASK);
  end;
end;

procedure TCustomImageList.InsertImage(Index: Integer; Image, Mask: TBitmap;
  MaskColor: TColor);
var
  I: Integer;
  OldImage, OldMask: TBitmap;
  TempList: TCustomImageList;
begin
  BeginUpdate;
  try
    OldImage := TBitmap.Create;
    try
      with OldImage do
      begin
        Height := FHeight;
        Width := FWidth;
      end;
      OldMask := TBitmap.Create;
      try
        with OldMask do
        begin
          Monochrome := True;
          Height := FHeight;
          Width := FWidth;
        end;
        TempList := TCustomImageList.CreateSize(5, 5);
        try
          TempList.Assign(Self);
          Clear;
          if Index > TempList.Count then
            raise EInvalidOperation.Create(SImageIndexError);
          for I := 0 to Index - 1 do
          begin
            TempList.GetImages(I, OldImage, OldMask);
            Add(OldImage, OldMask);
          end;
          if MaskColor <> -1 then
            AddMasked(Image, MaskColor) else
            Add(Image, Mask);
          for I := Index to TempList.Count - 1 do
          begin
            TempList.GetImages(I, OldImage, OldMask);
            Add(OldImage, OldMask);
          end;
        finally
          TempList.Free;
        end;
      finally
        OldMask.Free;
      end;
    finally
      OldImage.Free;
    end;
  finally
    EndUpdate;
  end;
end;

procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap);
begin
  InsertImage(Index, Image, Mask, -1);
end;

procedure TCustomImageList.InsertMasked(Index: Integer; Image: TBitmap;
  MaskColor: TColor);
begin
  InsertImage(Index, Image, nil, MaskColor);
end;

procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon);
var
  I: Integer;
  TempList: TCustomImageList;
  Icon: TIcon;
begin
  Icon := nil;
  TempList := nil;
  BeginUpdate;
  try
    TempList := TCustomImageList.CreateSize(5, 5);
    TempList.Assign(Self);
    Clear;
    if Index > TempList.Count then raise EInvalidOperation.Create(SImageIndexError);
    Icon := TIcon.Create;
    for I := 0 to Index - 1 do
    begin
      TempList.GetIcon(I, Icon);
      AddIcon(Icon);
    end;
    AddIcon(Image);
    for I := Index to TempList.Count - 1 do
    begin
      TempList.GetIcon(I, Icon);
      AddIcon(Icon);
    end;
  finally
    EndUpdate;
    Icon.Free;
    TempList.Free;
  end;
end;

procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
var
  Image, Mask: TBitmap;
begin
  if CurIndex <> NewIndex then
  begin
    Image := TBitmap.Create;
    try
      with Image do
      begin
        Height := FHeight;
        Width := FWidth;
      end;
      Mask := TBitmap.Create;
      try
        with Mask do
        begin
          Height := FHeight;
          Width := FWidth;
        end;
        GetImages(CurIndex, Image, Mask);
        Delete(CurIndex);
        Insert(NewIndex, Image, Mask);
      finally
        Mask.Free;
      end;
    finally
      Image.Free;
    end;
  end;
end;

function TCustomImageList.AddImage(Value: TCustomImageList; Index: Integer): Integer;
begin
  if Value <> nil then
  begin
    Result := Count;
    CopyImages(Value.Handle, Index);
  end else
    Result := -1;
end;

procedure TCustomImageList.AddImages(Value: TCustomImageList);
begin
  if Value <> nil then CopyImages(Value.Handle);
end;

procedure TCustomImageList.Assign(Source: TPersistent);
var
  ImageList: TCustomImageList;
begin
  if Source = nil then FreeHandle
  else if Source is TCustomImageList then
  begin
    Clear;
    ImageList := TCustomImageList(Source);
    Masked := ImageList.Masked;
    ImageType := ImageList.ImageType;
    DrawingStyle := ImageList.DrawingStyle;
    ShareImages := ImageList.ShareImages;
    SetNewDimensions(ImageList.Handle);
    if not HandleAllocated then HandleNeeded
    else ImageList_SetIconSize(Handle, Width, Height);
    BkColor := GetColor(ImageList_GetBkColor(ImageList.Handle));
    BlendColor := ImageList.BlendColor;
    AddImages(ImageList);
  end
  else inherited Assign(Source);
end;

procedure TCustomImageList.AssignTo(Dest: TPersistent);
var
  ImageList: TCustomImageList;
begin
  if Dest is TCustomImageList then
  begin
    ImageList := TCustomImageList(Dest);
    ImageList.Masked := Masked;
    ImageList.ImageType := ImageType;
    ImageList.DrawingStyle := DrawingStyle;
    ImageList.ShareImages := ShareImages;
    ImageList.BlendColor := BlendColor;
    with ImageList do
    begin
      Clear;
      SetNewDimensions(Self.Handle);
      if not HandleAllocated then HandleNeeded
      else ImageList_SetIconSize(Handle, Width, Height);
      BkColor := GetColor(ImageList_GetBkColor(Self.Handle));
      AddImages(Self);
    end;
  end
  else inherited AssignTo(Dest);
end;

procedure TCustomImageList.CheckImage(Image: TGraphic);
begin