cursorview.pas

一个窗口控制TCursorView显示静态或动画的游标在一种形式。控制使用标准的静态类节目,栩栩如生的API来窗口的鼠标,因为那是非常小。

{------------------------------------------------------------------------------}
{                                                                              }
{  TCursorView v1.02                                                           }
{  by Kambiz R. Khojasteh                                                      }
{                                                                              }
{  [e-mail]                                                       }
{  http://www.delphiarea.com                                                   }
{                                                                              }
{------------------------------------------------------------------------------}

{$I DELPHIAREA.INC}

unit CursorView;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls;

type
  TCustomCursorView = class(TWinControl)
  private
    {$IFNDEF COMPILER4_UP}
    fAutoSize: Boolean;
    {$ENDIF}
    fBorderStyle: TStaticBorderStyle;
    fCursorHandle: HCURSOR;
    fCursorHeight: Integer;
    fCursorWidth: Integer;
    fFileName: TFileName;
    fReleaseHandle: Boolean;
    {$IFNDEF COMPILER4_UP}
    procedure SetAutoSize(Value: Boolean);
    {$ENDIF}
    procedure SetBorderStyle(Value: TStaticBorderStyle);
    procedure SetCursorHandle(Value: HCURSOR);
    procedure SetFileName(const Value: TFileName);
    {$IFNDEF COMPILER4_UP}
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    {$ENDIF}
  protected
    procedure CalcCursorSize; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    {$IFDEF COMPILER4_UP}
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    {$ELSE}
    procedure Loaded; override;
    procedure AdjustSize; virtual;
    property AutoSize: Boolean read fAutoSize write SetAutoSize default False;
    {$ENDIF}
    property BorderStyle: TStaticBorderStyle read fBorderStyle write SetBorderStyle default sbsNone;
    property FileName: TFileName read fFileName write SetFileName;
    property ReleaseHandle: Boolean read fReleaseHandle write fReleaseHandle default True;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property CursorHandle: HCURSOR read fCursorHandle write SetCursorHandle;
    property CursorHeight: Integer read fCursorHeight;
    property CursorWidth: Integer read fCursorWidth;
  published
    property Width default 32;
    property Height default 32;
  end;

  TCursorView = class(TCustomCursorView)
  published
    property Align;
    {$IFDEF COMPILER4_UP}
    property Anchors;
    {$ENDIF}
    property AutoSize;
    {$IFDEF COMPILER4_UP}
    property BevelEdges;
    property BevelInner;
    property BevelKind default bkNone;
    property BevelOuter;
    {$ENDIF}
    property BorderStyle;
    property Color;
    {$IFDEF COMPILER4_UP}
    property Constraints;
    {$ENDIF}
    property DragCursor;
    {$IFDEF COMPILER4_UP}
    property DragKind;
    {$ENDIF}
    property DragMode;
    property Enabled;
    property FileName;
    property Hint;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ReleaseHandle;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    {$IFDEF COMPILER5_UP}
    property OnContextPopup;
    {$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF COMPILER4_UP}
    property OnEndDock;
    {$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    {$IFDEF COMPILER4_UP}
    property OnStartDock;
    {$ENDIF}
    property OnStartDrag;
  end;

implementation

{ TCursorView }

constructor TCustomCursorView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csSetCaption];
  Width := 32;
  Height := 32;
  fReleaseHandle := True;
end;

destructor TCustomCursorView.Destroy;
begin
  CursorHandle := 0;
  inherited Destroy;
end;

procedure TCustomCursorView.CreateParams(var Params: TCreateParams);
const
  Borders: array[TStaticBorderStyle] of DWORD = (0, WS_BORDER, SS_SUNKEN);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'STATIC');
  Params.Style := Params.Style or SS_NOTIFY or SS_ICON or SS_CENTERIMAGE or
    Borders[BorderStyle];
end;

procedure TCustomCursorView.CreateWnd;
begin
  inherited CreateWnd;
  if CursorHandle <> 0 then
    SendMessage(WindowHandle, STM_SETIMAGE, IMAGE_CURSOR, CursorHandle);
end;

{$IFDEF COMPILER4_UP}
function TCustomCursorView.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or
    (CursorHeight > 0) and (CursorWidth > 0) then
  begin
    if Align in [alNone, alTop, alBottom] then
      NewHeight := CursorHeight + Height - ClientHeight;
    if Align in [alNone, alLeft, alRight] then
      NewWidth := CursorWidth + Width - ClientWidth;
  end;
end;
{$ENDIF}

{$IFNDEF COMPILER4_UP}
procedure TCustomCursorView.Loaded;
begin
  inherited Loaded;
  if AutoSize then AdjustSize;
end;
{$ENDIF}

{$IFNDEF COMPILER4_UP}
procedure TCustomCursorView.AdjustSize;
begin
  if not (csLoading in ComponentState) and
    (CursorHeight > 0) and (CursorWidth > 0) then
  begin
    if Align in [alNone, alTop, alBottom] then
      ClientHeight := CursorHeight;
    if Align in [alNone, alLeft, alRight] then
      ClientWidth := CursorWidth;
  end;
end;
{$ENDIF}

{$IFNDEF COMPILER4_UP}
procedure TCustomCursorView.WMSize(var Msg: TWMSize);
begin
  inherited;
  if AutoSize then AdjustSize;
end;
{$ENDIF}

procedure TCustomCursorView.CalcCursorSize;
var
  IconInfo: TIconInfo;
  DIBSection: TDIBSection;
begin
  fCursorHeight := 0;
  fCursorWidth := 0;
  if CursorHandle <> 0 then
  begin
    GetIconInfo(CursorHandle, IconInfo);
    FillChar(DIBSection, SizeOf(DIBSection), 0);
    if IconInfo.hbmColor <> 0 then
      GetObject(IconInfo.hbmColor, SizeOf(DIBSection), @DIBSection)
    else
      GetObject(IconInfo.hbmMask, SizeOf(DIBSection), @DIBSection);
    if IconInfo.hbmColor = 0 then
      fCursorHeight := DIBSection.dsBm.bmHeight div 2
    else
      fCursorHeight := DIBSection.dsBm.bmHeight;
    fCursorWidth := DIBSection.dsbm.bmWidth;
  end;
end;

{$IFNDEF COMPILER4_UP}
procedure TCustomCursorView.SetAutoSize(Value: Boolean);
begin
  if AutoSize <> Value then
  begin
    fAutoSize := Value;
    if AutoSize then AdjustSize;
  end;
end;
{$ENDIF}

procedure TCustomCursorView.SetBorderStyle(Value: TStaticBorderStyle);
begin
  if BorderStyle <> Value then
  begin
    fBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TCustomCursorView.SetCursorHandle(Value: HCURSOR);
var
  OldCursorHandle: THandle;
begin
  if CursorHandle <> Value then
  begin
    OldCursorHandle := CursorHandle;
    fFileName := '';
    fCursorHandle := Value;
    if HandleAllocated then
      SendMessage(WindowHandle, STM_SETIMAGE, IMAGE_CURSOR, CursorHandle);
    if (OldCursorHandle <> 0) and ReleaseHandle then
      DestroyCursor(OldCursorHandle);
    CalcCursorSize;
    if AutoSize then AdjustSize;
  end;
end;

procedure TCustomCursorView.SetFileName(const Value: TFileName);
var
  Cursor: HCURSOR;
begin
  if UpperCase(FileName) <> UpperCase(Value) then
  begin
    if Value = '' then
      SetCursorHandle(0)
    else
    begin
      Cursor := LoadCursorFromFile(PChar(Value));
      if Cursor <> 0 then
      begin
        SetCursorHandle(Cursor);
        fFileName := Value;
      end
      else
      begin
        {$IFDEF COMPILER6_UP}
        RaiseLastOSError;
        {$ELSE}
        RaiseLastWin32Error;
        {$ENDIF}
      end;
    end;
  end;
end;

end.