jsimagelistxp.pas

销售软件

  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
  if Image <> nil then
    with Image do
      if (Height < FHeight) or (Width < FWidth) then
        raise EInvalidOperation.Create(SInvalidImageSize);
end;

procedure TCustomImageList.SetDrawingStyle(Value: TDrawingStyle);
begin
  if Value <> DrawingStyle then
  begin
    FDrawingStyle := Value;
    Change;
  end;
end;

function TCustomImageList.GetHotSpot: TPoint;
begin
  Result := Point(0, 0);
end;

function TCustomImageList.GetInstRes(Instance: THandle; ResType: TResType;
  ResID: DWORD; Width: Integer; LoadFlags: TLoadResources;
  MaskColor: TColor): Boolean;
begin
  Result := InternalGetInstRes(Instance, ResType, PChar(ResID), Width,
    LoadFlags, MaskColor);
end;

function TCustomImageList.GetInstRes(Instance: THandle; ResType: TResType;
  const Name: string; Width: Integer; LoadFlags: TLoadResources;
  MaskColor: TColor): Boolean;
begin
  Result := InternalGetInstRes(Instance, ResType, PChar(Name), Width,
    LoadFlags, MaskColor);
end;

function TCustomImageList.InternalGetInstRes(Instance: THandle;
  ResType: TResType; Name: PChar; Width: Integer; LoadFlags: TLoadResources;
  MaskColor: TColor): Boolean;
const
  ResMap: array[TResType] of Integer = (IMAGE_BITMAP, IMAGE_CURSOR, IMAGE_ICON);
var
  hImage: HImageList;
  Flags: Integer;
begin
  Flags := 0;
  if lrDefaultColor in LoadFlags then
    Flags := Flags or LR_DEFAULTCOLOR;
  if lrDefaultSize in LoadFlags then
    Flags := Flags or LR_DEFAULTSIZE;
  if lrFromFile in LoadFlags then
    Flags := Flags or LR_LOADFROMFILE;
  if lrMap3DColors in LoadFlags then
    Flags := Flags or LR_LOADMAP3DCOLORS;
  if lrTransparent in LoadFlags then
    Flags := Flags or LR_LOADTRANSPARENT;
  if lrMonoChrome in LoadFlags then
    Flags := Flags or LR_MONOCHROME;
  hImage := ImageList_LoadImage(Instance, Name, Width, AllocBy, MaskColor,
    ResMap[ResType], Flags);
  if hImage <> 0 then
  begin
    CopyImages(hImage);
    ImageList_Destroy(hImage);
    Result := True;
  end
  else
    Result := False;
end;

function TCustomImageList.GetResource(ResType: TResType; const Name: string;
  Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
begin
  Result := GetInstRes(MainInstance, ResType, Name, Width, LoadFlags,
    MaskColor);
end;

function TCustomImageList.ResInstLoad(Instance: THandle; ResType: TResType;
  const Name: string; MaskColor: TColor): Boolean;
begin
  Result := GetInstRes(Instance, ResType, Name, Width, [], MaskColor);
end;

function TCustomImageList.ResourceLoad(ResType: TResType; const Name: string;
  MaskColor: TColor): Boolean;
var
  LibModule: PLibModule;
begin
  Result := False;
  if HInstance = MainInstance then
    Result := GetInstRes(MainInstance, ResType, Name, Width, [], MaskColor)
  else
  begin
    LibModule := LibModuleList;
    while LibModule <> nil do
      with LibModule^ do
      begin
        Result := GetInstRes(ResInstance, ResType, Name, Width, [], MaskColor);
        if not Result and (Instance <> ResInstance) then
          Result := GetInstRes(Instance, ResType, Name, Width, [], MaskColor);
        if Result then
          Exit;
        LibModule := LibModule.Next;
      end;
  end;
end;

function TCustomImageList.FileLoad(ResType: TResType; const Name: string;
  MaskColor: TColor): Boolean;
begin
  Result := GetResource(ResType, Name, Width, [lrFromFile], MaskColor);
end;

procedure TCustomImageList.Change;