lazarus/lcl/include/cursorimage.inc

{%MainUnit ../graphics.pp}

{******************************************************************************
                             TCursorImage
 ******************************************************************************

 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL, included in this distribution,        *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************
}


{ TSharedCursorImage }

procedure TSharedCursorImage.FreeHandle;
begin
  if FHandle = 0 then Exit;

  DestroyCursor(FHandle);
  FHandle := 0;
end;

class function TSharedCursorImage.GetImagesClass: TIconImageClass;
begin
  Result := TCursorImageImage;
end;

////////////////////////////////////////////////////////////////////////////////

{ TCursorImage }

class function TCursorImage.GetFileExtensions: string;
begin
  Result := 'cur';
end;

class function TCursorImage.GetSharedImageClass: TSharedRasterImageClass;
begin
  Result := TSharedCursorImage;
end;

function TCursorImage.LazarusResourceTypeValid(const ResourceType: string): boolean;
var
  ResType: String;
begin
  if Length(ResourceType) < 3 then Exit(False);

  ResType := UpperCase(ResourceType);
  case ResType[1] of
    'C': begin
      Result := (ResType = 'CUR') or (ResType = 'CURSOR');
    end;
  else
    Result := inherited LazarusResourceTypeValid(ResType);
  end;
end;

function TCursorImage.ReleaseHandle: HCURSOR;
begin
  HandleNeeded;
  Result := FSharedImage.ReleaseHandle;
end;

function TCursorImage.GetCursorHandle: HCURSOR;
begin
  Result := GetHandle;
end;

procedure TCursorImage.SetCursorHandle(AValue: HCURSOR);
begin
  SetHandle(AValue);
end;

function TCursorImage.GetHotSpot: TPoint;
begin
  if FCurrent = -1
  then Result := Point(0, 0)
  else Result := TCursorImageImage(TSharedCursorImage(FSharedImage).FImages[FCurrent]).HotSpot;
end;

procedure TCursorImage.HandleNeeded;
var
  IconInfo: TIconInfo;
  h: TPoint;
begin
  if FSharedImage.FHandle <> 0 then Exit;

  IconInfo.fIcon := False;
  H := HotSpot;
  IconInfo.xHotspot := H.X;
  IconInfo.yHotSpot := H.Y;
  IconInfo.hbmMask := MaskHandle;
  IconInfo.hbmColor := BitmapHandle;
  FSharedImage.FHandle := WidgetSet.CreateCursor(@IconInfo);
end;