Panning Window Image is not DPI scaled

[pyscripter]

See image below (300% scaling) . Looks tiny compared to the mouse image.

The size of the panning window and FPanningImage need to be scaled.

Also a question. Why include and load panning cursors and panning images as resources, when they are available on Windows.

See https://learn.microsoft.com/en-us/windows/win32/menurc/about-cursors.

For instance the VT_MOVEALL cursor can be loaded with

LoadCursor(0, MAKEINTRESOURCE(32654))

[joachimmarder]

Also a question. Why include and load panning cursors and panning images as resources, when they are available on Windows.

Good question. I guess the answer is simply: Windows 95 did not have this cursor available.

... FPanningImage need to be scaled.

As you suggested we should use Windows cursor instead.

[joachimmarder]

Using Windows cursors is working now. With the just committed code FPanningImage is scaled by the primary monitor (automatically by Windows), not yet by the current monitor.

[joachimmarder]

@pyscripter : I would appreciate some testing of the current code. I already recognized that scaling the cursor is a little ugly at 125%, but all is done using Windows API. I have currently no idea how to improve this.

[pyscripter]

I would recommend adding the cursors the Delphi way and then using them, instead of creating and destroying them each time:

// Add the panning cursors to Screen.Cursors

TPanningCursor = (
    MoveAll = 32654,
    MoveNS = 32652,
    MoveEW = 32653,
    MoveN = 32655,
    MoveNE = 32660,
    MoveE = 32658,
    MoveSE = 32662,
    MoveS = 32656,
    MoveSW = 32661,
    MoveW = 32657,
    MoveNW = 32659
  );
  TPanningCursors = array of TPanningCursor;
const
  PanningCursors: TPanningCursors =
    [MoveAll, MoveNS, MoveEW, MoveN, MoveNE, MoveE,
     MoveSE, MoveS, MoveSW, MoveW, MoveNW];

  for var PanningCursor in PanningCursors do
    Screen.Cursors[TCursor(PanningCursor)] := LoadCursor(0, MakeIntResource(PanningCursor));

Then you can access the cursors by

Screen.Cursors[TCursor(MoveE)];

or set the cursor of control by

Cursor := TCursor(MoveE);

[pyscripter]

Also Copilot gives me the following code to get the cursor as bitmap, The bitmap can then be drawn on the panning form.

procedure GetCursorBitmap(Cursor: HCURSOR; Bitmap: TBitmap);
var
  IconInfo: TIconInfo;
begin
  // Get information about the cursor
  if GetIconInfo(Cursor, IconInfo) then
  try
    // Assign the mask bitmap to the TBitmap
    Bitmap.Handle := IconInfo.hbmMask;
  finally
    // Clean up
    DeleteObject(IconInfo.hbmMask);
    DeleteObject(IconInfo.hbmColor);
  end;
end;

[joachimmarder]

I would recommend adding the cursors the Delphi way and then using them, instead of creating and destroying them each time

This approach consumes several resources (handles) when not actually needing them. I don't see much benefit here.

[pyscripter]

This approach consumes several resources (handles) when not actually needing them. I don't see much benefit here.

Ok.

[joachimmarder]

Also Copilot gives me the following code to get the cursor as bitmap

I tested this code but found glitches when drawing the bitmap. Working with a TIcon worked more reliable. It seems that a cursor and an icon are internally very similar.

[pyscripter]

It seems that a cursor and an icon are internally very similar.

I think they are identical. I will test and report back.

[pyscripter]

Please see the video below (enable sound in playback). This is on a high DPI monitor, but there are similar issues on 96 DPI monitor. Two issues:

• Panning image is not painted correctly
• Long delay in showing the panning image and the panning cursor

https://github.com/user-attachments/assets/863b7d84-6c85-4c42-b171-6f576a4aa476

[pyscripter]

I am not sure what all these Clipping regions and the comparison to clFuchsia are doing. Probably this had to do with the way the resource image was done. Now the cursor contains a transparent icon. I think all is needed is to be painted transparently.

I will have another look tomorrow.

[pyscripter]

The following code seems to work quite reliably:

procedure TForm1.Button1Click(Sender: TObject);
var
  Form: TForm;
  Image: TImage;
  IconHandle: HIcon;
begin
  Form := TForm.Create(Self);
  Form.PopupMode := pmExplicit;
  Form.PopupParent := Self;
  Form.TransparentColor := True;
  Form.TransparentColorValue := clBtnFace;
  Form.StyleElements := [];
  Form.Autosize := True;
  Form.BorderStyle := bsNone;
  Image := TImage.Create(Form);
  Image.Left := 0;
  Image.Top := 0;
  Image.Parent := Form;
  IconHandle := LoadCursor(0, MakeIntResource(32654));
  Image.Picture.Icon.Handle := IconHandle;
  Image.AutoSize := True;
  Form.Left := Left + Width div 2;
  Form.Top := Top + Height div 2;
  Form.Position := poDesigned;
  Form.Show;
end;

What is missing is the scaling of the image.

[pyscripter]

The following handles resizing with high quality as well:

uses
  Winapi.Wincodec;


procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: Integer);
{$if CompilerVersion >= 34}
// See https://quality.embarcadero.com/browse/RSP-26621
var
  Factory: IWICImagingFactory;
  Scaler: IWICBitmapScaler;
  Source : TWICImage;
begin
  Bitmap.AlphaFormat := afDefined;
  Source := TWICImage.Create;
  try
    Source.Assign(Bitmap);
    Factory := TWICImage.ImagingFactory;
    Factory.CreateBitmapScaler(Scaler);
    try
      Scaler.Initialize(Source.Handle, NewWidth, NewHeight,
        WICBitmapInterpolationModeHighQualityCubic);
      Source.Handle := IWICBitmap(Scaler);
    finally
      Scaler := nil;
      Factory := nil;
    end;
    Bitmap.Assign(Source);
  finally
    Source.Free;
  end;
{$else}
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.SetSize(NewWidth, NewHeight);
    SetStretchBltMode(B.Canvas.Handle, STRETCH_HALFTONE);
    B.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap);
    Bitmap.SetSize(NewWidth, NewHeight);
    Bitmap.Canvas.Draw(0, 0, B);
  finally
    B.Free;
  end;
{$ifend}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Form: TForm;
  Image: TImage;
  IconHandle: HIcon;
  Icon: TIcon;
begin
  Form := TForm.Create(Self);
  Form.PopupMode := pmExplicit;
  Form.PopupParent := Self;
  Form.TransparentColor := True;
  Form.TransparentColorValue := clBtnFace;
  Form.Autosize := True;
  Form.BorderStyle := bsNone;
  Form.StyleElements := [];
  Image := TImage.Create(Form);
  Image.Left := 0;
  Image.Top := 0;
  Image.Parent := Form;
  IconHandle := LoadCursor(0, MakeIntResource(32654));
  Icon := TIcon.Create;
  try
    Icon.Handle := IconHandle;
    Image.Picture.Bitmap.Assign(Icon);
  finally
    Icon.Free;
    DeleteObject(IconHandle);
  end;
  ResizeBitmap(Image.Picture.Bitmap, 64, 64);
  Image.AutoSize := True;
  Form.Left := Left + Width div 2;
  Form.Top := Top + Height div 2;
  Form.Position := poDesigned;
  Form.Show;
end;

Note regarding the ifdef in the ResizeBitmap code: There was a bug before Sydney due to which TWICImage handled pre-multiplied alpha values incorrectly. However in this case the alpha values are either 0 or 1, so that bug should have no effect. It would make no difference whether the alpha values are pre-multiplied or not, so the Syndey code should work correctly with earlier versions.

[pyscripter]

I have further simplified the code:

procedure ScaledIconToBitmap(Bitmap: TBitmap; SourceIcon: hIcon; const NewWidth, NewHeight: Integer);
var
  Factory: IWICImagingFactory;
  Scaler: IWICBitmapScaler;
  Source : TWICImage;
  IBitmap: IWICBitmap;
begin
  Source := TWICImage.Create;
  try
    Factory := TWICImage.ImagingFactory;
    Factory.CreateBitmapFromHICON(SourceIcon, IBitmap);

    Source.Assign(Bitmap);
    Factory.CreateBitmapScaler(Scaler);
      Scaler.Initialize(IBitmap, NewWidth, NewHeight,
        WICBitmapInterpolationModeHighQualityCubic);
      Source.Handle := IWICBitmap(Scaler);
    Bitmap.Assign(Source);
    Scaler := nil;
    Factory := nil; //See https://embt.atlassian.net/servicedesk/customer/portal/1/RSS-2178
  finally
    Source.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Form: TForm;
  Image: TImage;
  IconHandle: HIcon;
begin
  Form := TForm.Create(Self);
  Form.PopupMode := pmExplicit;
  Form.PopupParent := Self;
  Form.TransparentColor := True;
  Form.TransparentColorValue := clBtnFace;
  Form.Autosize := True;
  Form.BorderStyle := bsNone;
  Form.StyleElements := [];
  Image := TImage.Create(Form);
  Image.Left := 0;
  Image.Top := 0;
  Image.Parent := Form;
  IconHandle := LoadCursor(0, MakeIntResource(32654));
  ScaledIconToBitmap(Image.Picture.Bitmap, IconHandle, 64, 64);
  Image.AutoSize := True;
  Form.Left := Left + Width div 2;
  Form.Top := Top + Height div 2;
  Form.Position := poDesigned;
  Form.Show;
end;

This is so much simpler than the current code. No cryptic Windows API calls, no clipping regions, no WindProc and handling of WM_PAINT messages, much easier to understand and maintain.

[joachimmarder]

This is so much simpler than the current code. No cryptic Windows API calls, no clipping regions, no WindProc and handling of WM_PAINT messages, much easier to understand and maintain.

I fully agree, I will change the code accordingly later this week, and in a second step address scaling.

[pyscripter]

Thanks, Looks good!