jsimagelistxp.pas

销售软件

unit JSImageListXP;

{$R-,T-,H+,X+}

interface

uses Windows, Classes, Controls, Graphics, CommCtrl;

type

  { TChangeLink }

  TCustomImageList = class;

  TChangeLink = class(TObject)
  private
    FSender: TCustomImageList;
    FOnChange: TNotifyEvent;
  public
    destructor Destroy; override;
    procedure Change; dynamic;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Sender: TCustomImageList read FSender write FSender;
  end;

  { TCustomImageList }

  TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent);
  TImageType = (itImage, itMask);
  TResType = (rtBitmap, rtCursor, rtIcon);
  TOverlay = 0..3;
  TLoadResource = (lrDefaultColor, lrDefaultSize, lrFromFile,
    lrMap3DColors, lrTransparent, lrMonoChrome);
  TLoadResources = set of TLoadResource;
  TImageIndex = type Integer;

  TCustomImageList = class(TComponent)
  private
    FHeight: Integer;
    FWidth: Integer;
    FAllocBy: Integer;
    FHandle: HImageList;
    FDrawingStyle: TDrawingStyle;
    FMasked: Boolean;
    FShareImages: Boolean;
    FImageType: TImageType;
    FBkColor: TColor;
    FBlendColor: TColor;
    FClients: TList;
    FBitmap: TBitmap;
    FMonoBitmap: TBitmap;
    FChanged: Boolean;
    FUpdateCount: Integer;
    FOnChange: TNotifyEvent;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure InitBitmap;
    procedure CheckImage(Image: TGraphic);
    procedure CopyImages(Value: HImageList; Index: Integer = -1);
    procedure CreateImageList;
    function Equal(IL: TCustomImageList): Boolean;
    procedure FreeHandle;
    function GetCount: Integer;
    function GetBitmapHandle(Bitmap: HBITMAP): HBITMAP;
    function GetBkColor: TColor;
    function GetHandle: HImageList;
    function GetImageHandle(Image, ImageDDB: TBitmap): HBITMAP;
    procedure InsertImage(Index: Integer; Image, Mask: TBitmap; MaskColor:
      TColor);
    function InternalGetInstRes(Instance: THandle; ResType: TResType;
      Name: PChar; Width: Integer; LoadFlags: TLoadResources;
      MaskColor: TColor): Boolean;
    procedure SetBkColor(Value: TColor);
    procedure SetDrawingStyle(Value: TDrawingStyle);
    procedure SetHandle(Value: HImageList);
    procedure SetHeight(Value: Integer);
    procedure SetNewDimensions(Value: HImageList);
    procedure SetWidth(Value: Integer);
    procedure ReadD2Stream(Stream: TStream);
    procedure ReadD3Stream(Stream: TStream);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure Change; dynamic;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
      Style: Cardinal; Enabled: Boolean = True); virtual;
    procedure GetImages(Index: Integer; Image, Mask: TBitmap);
    procedure HandleNeeded;
    procedure Initialize; virtual;
    procedure ReadData(Stream: TStream); virtual;
    procedure WriteData(Stream: TStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateSize(AWidth, AHeight: Integer);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Add(Image, Mask: TBitmap): Integer;
    function AddIcon(Image: TIcon): Integer;
    function AddImage(Value: TCustomImageList; Index: Integer): Integer;
    procedure AddImages(Value: TCustomImageList);
    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Draw(Canvas: TCanvas; X, Y, Index: Integer;
      Enabled: Boolean = True); overload;
    procedure Draw(Canvas: TCanvas; X, Y, Index: Integer;
      ADrawingStyle: TDrawingStyle; AImageType: TImageType;
      Enabled: Boolean = True); overload;
    procedure DrawOverlay(Canvas: TCanvas; X, Y: Integer;
      ImageIndex: Integer; Overlay: TOverlay; Enabled: Boolean = True);
        overload;
    procedure DrawOverlay(Canvas: TCanvas; X, Y: Integer;
      ImageIndex: Integer; Overlay: TOverlay; ADrawingStyle: TDrawingStyle;
      AImageType: TImageType; Enabled: Boolean = True); overload;
    function FileLoad(ResType: TResType; const Name: string;
      MaskColor: TColor): Boolean;
    function GetBitmap(Index: Integer; Image: TBitmap): Boolean;
    function GetHotSpot: TPoint; virtual;
    procedure GetIcon(Index: Integer; Image: TIcon); overload;
    procedure GetIcon(Index: Integer; Image: TIcon; ADrawingStyle:
      TDrawingStyle;
      AImageType: TImageType); overload;
    function GetImageBitmap: HBITMAP;
    function GetMaskBitmap: HBITMAP;
    function GetResource(ResType: TResType; const Name: string;
      Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
    function GetInstRes(Instance: THandle; ResType: TResType; const Name:
      string;
      Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
        overload;
    function GetInstRes(Instance: THandle; ResType: TResType; ResID: DWORD;
      Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
        overload;
    function HandleAllocated: Boolean;
    procedure Insert(Index: Integer; Image, Mask: TBitmap);
    procedure InsertIcon(Index: Integer; Image: TIcon);
    procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
    procedure Move(CurIndex, NewIndex: Integer);
    function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
    procedure RegisterChanges(Value: TChangeLink);
    function ResourceLoad(ResType: TResType; const Name: string;
      MaskColor: TColor): Boolean;
    function ResInstLoad(Instance: THandle; ResType: TResType;
      const Name: string; MaskColor: TColor): Boolean;
    procedure Replace(Index: Integer; Image, Mask: TBitmap);
    procedure ReplaceIcon(Index: Integer; Image: TIcon);
    procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor:
      TColor);
    procedure UnRegisterChanges(Value: TChangeLink);
    property Count: Integer read GetCount;
    property Handle: HImageList read GetHandle write SetHandle;
  public
    property AllocBy: Integer read FAllocBy write FAllocBy default 4;
    property BlendColor: TColor read FBlendColor write FBlendColor default
      clNone;
    property BkColor: TColor read GetBkColor write SetBkColor default clNone;
    property DrawingStyle: TDrawingStyle read FDrawingStyle write SetDrawingStyle
      default dsNormal;
    property Height: Integer read FHeight write SetHeight default 16;
    property ImageType: TImageType read FImageType write FImageType default
      itImage;
    property Masked: Boolean read FMasked write FMasked default True;
    property ShareImages: Boolean read FShareImages write FShareImages default
      False;
    property Width: Integer read FWidth write SetWidth default 16;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  { TDragImageList }
  TDragImageList = class(TCustomImageList)
  private
    FDragCursor: TCursor;
    FDragging: Boolean;
    FDragHandle: HWND;
    FDragHotspot: TPoint;
    FDragIndex: Integer;
    FOldCursor: TCursor;
    procedure SetDragCursor(Value: TCursor);
  protected
    procedure Initialize; override;
  public
    function BeginDrag(Window: HWND; X, Y: Integer): Boolean;
    function DragLock(Window: HWND; XPos, YPos: Integer): Boolean;
    function DragMove(X, Y: Integer): Boolean;
    procedure DragUnlock;
    function EndDrag: Boolean;
    function GetHotSpot: TPoint; override;
    procedure HideDragImage;
    function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;
    procedure ShowDragImage;
    property DragCursor: TCursor read FDragCursor write SetDragCursor;
    property DragHotspot: TPoint read FDragHotspot write FDragHotspot;
    property Dragging: Boolean read FDragging;
  end;

  TJSImageListXP = class(TDragImageList)
  published
    property BlendColor;
    property BkColor;
    property AllocBy;
    property DrawingStyle;
    property Height;
    property ImageType;
    property Masked;
    property OnChange;
    property ShareImages;
    property Width;
  end;

procedure Register;

implementation

uses
  SysUtils, Consts, Forms, ActiveX;

procedure Register;
begin
  RegisterComponents('Jerk System', [TJSImageListXP]);
end;

{ TCustomImageList }

const
  DrawingStyles: array[TDrawingStyle] of Longint = (ILD_FOCUS, ILD_SELECTED,
    ILD_NORMAL, ILD_TRANSPARENT);
  Images: array[TImageType] of Longint = (0, ILD_MASK);

function GetRGBColor(Value: TColor): DWORD;
begin
  Result := ColorToRGB(Value);
  case Result of
    clNone: Result := CLR_NONE;
    clDefault: Result := CLR_DEFAULT;
  end;
end;

function GetColor(Value: DWORD): TColor;
begin
  case Value of
    CLR_NONE: Result := clNone;
    CLR_DEFAULT: Result := clDefault;
  else
    Result := TColor(Value);
  end;
end;

constructor TCustomImageList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWidth := 16;
  FHeight := 16;
  Initialize;
end;

constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer);
begin
  inherited Create(nil);
  FWidth := AWidth;
  FHeight := AHeight;
  Initialize;
end;

destructor TCustomImageList.Destroy;
begin
  while FClients.Count > 0 do
    UnRegisterChanges(TChangeLink(FClients.Last));
  FBitmap.Free;
  FreeHandle;
  FClients.Free;
  FClients := nil;
  if FMonoBitmap <> nil then
    FMonoBitmap.Free;
  inherited Destroy;
end;

procedure TCustomImageList.Initialize;
const
  MaxSize = 32768;
begin
  FClients := TList.Create;
  if (Height < 1) or (Height > MaxSize) or (Width < 1) then
    raise EInvalidOperation.Create(SInvalidImageSize);
  AllocBy := 4;
  Masked := True;
  DrawingStyle := dsNormal;
  ImageType := itImage;
  FBkColor := clNone;
  FBlendColor := clNone;
  FBitmap := TBitmap.Create;
  InitBitmap;
end;

function TCustomImageList.HandleAllocated: Boolean;
begin
  Result := FHandle <> 0;
end;

procedure TCustomImageList.HandleNeeded;
begin
  if FHandle = 0 then
    CreateImageList;
end;

procedure TCustomImageList.InitBitmap;
var
  ScreenDC: HDC;
begin
  ScreenDC := GetDC(0);
  try
    with FBitmap do
    begin
      Handle := CreateCompatibleBitmap(ScreenDC, Self.Width, Self.Height);
      Canvas.Brush.Color := clBlack;
      Canvas.FillRect(Rect(0, 0, Width, Height));
    end;
  finally
    ReleaseDC(0, ScreenDC);
  end;
  if FMonoBitmap <> nil then
  begin
    FMonoBitmap.Free;
    FMonoBitmap := nil;
  end;
end;

procedure TCustomImageList.SetNewDimensions(Value: HImageList);
var
  AHeight, AWidth: Integer;
begin
  AWidth := Width;
  AHeight := Height;
  ImageList_GetIconSize(Value, AWidth, AHeight);
  FWidth := AWidth;
  FHeight := AHeight;
  InitBitmap;
end;

procedure TCustomImageList.SetWidth(Value: Integer);
begin
  if Value <> Width then
  begin
    FWidth := Value;
    if HandleAllocated then
      ImageList_SetIconSize(FHandle, Width, Height);
    Clear;
    InitBitmap;
    Change;
  end;
end;

procedure TCustomImageList.SetHeight(Value: Integer);
begin
  if Value <> Height then
  begin
    FHeight := Value;
    if HandleAllocated then
      ImageList_SetIconSize(FHandle, Width, Height);
    Clear;
    InitBitmap;
    Change;
  end;
end;

procedure TCustomImageList.SetHandle(Value: HImageList);
begin
  FreeHandle;
  if Value <> 0 then
  begin
    SetNewDimensions(Value);
    FHandle := Value;
    Change;
  end;
end;

function TCustomImageList.GetBitmapHandle(Bitmap: HBITMAP): HBITMAP;
begin
  if Bitmap <> 0 then
    Result := Bitmap
  else
    Result := FBitmap.Handle;
end;

function TCustomImageList.GetHandle: HImageList;
begin
  HandleNeeded;
  Result := FHandle;
end;

function TCustomImageList.GetImageHandle(Image, ImageDDB: TBitmap): HBITMAP;
begin
  CheckImage(Image);
  if Image <> nil then
    if Image.HandleType = bmDDB then
      Result := Image.Handle
    else
    begin
      ImageDDB.Assign(Image);
      ImageDDB.HandleType := bmDDB;
      Result := ImageDDB.Handle;
    end
  else
    Result := FBitmap.Handle;
end;

procedure TCustomImageList.FreeHandle;
begin
  if HandleAllocated and not ShareImages then
    ImageList_Destroy(Handle);
  FHandle := 0;
  Change;
end;

procedure TCustomImageList.CreateImageList;
const
  Mask: array[Boolean] of Longint = (0, ILC_MASK);
begin
  FHandle := ImageList_Create(Width, Height, ILC_COLORDDB or Mask[Masked],
    AllocBy, AllocBy);
  if not HandleAllocated then
    raise EInvalidOperation.Create(SInvalidImageList);
  if FBkColor <> clNone then
    BkColor := FBkColor;
end;

function TCustomImageList.GetImageBitmap: HBITMAP;
var
  Info: TImageInfo;
begin
  if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  begin
    Result := Info.hbmImage;
    DeleteObject(Info.hbmMask);
  end
  else
    Result := 0;
end;

function TCustomImageList.GetMaskBitmap: HBITMAP;
var
  Info: TImageInfo;
begin
  if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  begin
    Result := Info.hbmMask;
    DeleteObject(Info.hbmImage);
  end
  else
    Result := 0;
end;

function TCustomImageList.Add(Image, Mask: TBitmap): Integer;
var
  ImageDDB, MaskDDB: TBitmap;
begin
  ImageDDB := TBitmap.Create;
  try
    MaskDDB := TBitmap.Create;
    try
      HandleNeeded;
      Result := ImageList_Add(FHandle, GetImageHandle(Image, ImageDDB),
        GetImageHandle(Mask, MaskDDB));
    finally
      MaskDDB.Free;
    end;
  finally
    ImageDDB.Free;
  end;
  Change;
end;

function TCustomImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
var
  ImageDDB: TBitmap;
begin
  ImageDDB := TBitmap.Create;
  try
    if Masked and (MaskColor <> -1) then
    begin
      with TBitmap.Create do
      try
        Assign(Image);
        TransparentColor := MaskColor;
        Self.HandleNeeded;
        Result := ImageList_Add(Self.FHandle, GetImageHandle(Image, ImageDDB),
          GetBitmapHandle(MaskHandle));
      finally
        Free;
      end;
    end
    else
      Result := ImageList_Add(Handle, GetImageHandle(Image, ImageDDB), 0);
  finally
    ImageDDB.Free;
  end;
  Change;
end;

function TCustomImageList.AddIcon(Image: TIcon): Integer;
begin
  if Image = nil then
    Result := Add(nil, nil)
  else
  begin
    CheckImage(Image);
    Result := ImageList_AddIcon(Handle, Image.Handle);
  end;
  Change;
end;

function TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap): Boolean;
begin
  Result := (Image <> nil) and HandleAllocated and (Index > -1) and (Index <
    Count);
  if Result then
    with Image do
    begin
      Height := FHeight;
      Width := FWidth;
      Draw(Canvas, 0, 0, Index);
    end;
end;

procedure TCustomImageList.GetIcon(Index: Integer; Image: TIcon);
begin
  GetIcon(Index, Image, DrawingStyle, ImageType);
end;

procedure TCustomImageList.GetIcon(Index: Integer; Image: TIcon;
  ADrawingStyle: TDrawingStyle; AImageType: TImageType);
begin
  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