Can't stretch the video under the 2K / 4K screen

[H Visli]

My program need to play videos with full screen and run under 4k monitor (Windows 10 64bit, Firemonkey framework).

I found a post which fixing the TMediaPlayer scaling problem by @ Brovin yaroslav  and @ cezif : 

It works very fine under 1080p monitor (1920x1080).

But when I run my program under 4k monitor(3840x2160), the video can't been stretched with correct display.

Can any guys can help me to fix this problem? Thanks a lot.

Изменено 2 апреля, 2020 пользователем H Visli

[H Visli]

OK, I have basically located the cause of the problem, and the next step is how to fix this bug. 

[H Visli]

Finally solved. Although it is not perfect, but it can satisfy my use. Share to everyone: 

(Base on @ Brovin yaroslav  and @ cezif  's post, Thanks!)

procedure TWindowsMedia.UpdateMediaFromControl;
  function GetScreenScale: Single;
  var
    ScreenService: IFMXScreenService;
  begin
    Result := 1;
    if TPlatformServices.Current.SupportsPlatformService (IFMXScreenService, IInterface(ScreenService)) then
      Result := ScreenService.GetScreenScale;
  end;
var
  R: TRect;
  Bounds: TRectF;
  Form: TCommonCustomForm;
  ScaleRatio: Single;
begin
  FVMRWindowlessControl9.SetAspectRatioMode(VMR9ARMode_LetterBox);
  if FWnd <> 0 then
  begin
    if (Control <> nil) and not (csDesigning in Control.ComponentState) and (Control.ParentedVisible) and
       (Control.Root <> nil) and  (Control.Root.GetObject is TCommonCustomForm) then
    begin
      Form := TCommonCustomForm(Control.Root.GetObject);
      ScaleRatio := GetScreenScale;
      Bounds := TRectF.Create(0, 0, Control.AbsoluteWidth * ScaleRatio, Control.AbsoluteHeight * ScaleRatio);
      Bounds.Fit(RectF(0, 0, Control.AbsoluteWidth * ScaleRatio, Control.AbsoluteHeight * ScaleRatio));
      Bounds.Offset(Control.AbsoluteRect.Left, Control.AbsoluteRect.Top);
      SetParent(FWnd, WindowHandleToPlatform(Form.Handle).Wnd);
      SetWindowPos(FWnd, 0, Bounds.Round.Left, Bounds.Round.Top, Bounds.Round.Width, Bounds.Round.Height, 0);
      R := TRect.Create(0, 0, Bounds.Round.Width, Bounds.Round.Height);

      if FVMRWindowlessControl9 <> nil then
        FVMRWindowlessControl9.SetVideoPosition(nil, @R);
      if FVMRWindowlessControl7 <> nil then
        FVMRWindowlessControl7.SetVideoPosition(nil, @R);
      ShowWindow(FWnd, SW_SHOW)
    end
    else
    begin
      SetParent(FWnd, ApplicationHWND);
      ShowWindow(FWnd, SW_HIDE)
    end;
  end;
end;

 

Изменено 3 апреля, 2020 пользователем H Visli