source: DpiControls/Dpi.Common.pas

unit Dpi.Common;

interface

uses
  {$IFDEF WINDOWS}Windows,{$ENDIF}
  Classes, SysUtils, LCLType, Types, LCLIntf, Graphics, Math, Dpi.Graphics;

const
  DpiControlsComponentPaletteName = 'DpiControls';

function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
  YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer; Src: TCanvas;
  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY; Precise: Boolean = False): Boolean;
function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
{$IFDEF WINDOWS}
function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
  const lprcClip:RECT;hrgnUpdate:HRGN; lprcUpdate: LPRECT): WINBOOL; overload;
{$ENDIF}
function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint; const lprcScroll: TRect;
  const lprcClip:TRect; hrgnUpdate: HWND; lprcUpdate: PRect): Boolean; overload;
function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
  X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
function ScaleToNative(Value: Integer): Integer; inline;
function ScaleToNativeDist(Base, Value: Integer): Integer;
function ScaleFromNative(Value: Integer): Integer;
function ScalePointToNative(Value: TPoint): TPoint;
function ScalePointFromNative(Value: TPoint): TPoint;
function ScaleSizeToNative(Value: TSize): TSize;
function ScaleSizeFromNative(Value: TSize): TSize;
function ScaleRectToNative(Value: TRect): TRect;
function ScaleRectFromNative(Value: TRect): TRect;
function ScaleFloatToNative(Value: Double): Double;
function ScaleFloatFromNative(Value: Double): Double;
procedure WriteLog(Text: string);
function GetSystemMetrics(nIndex: Integer): Integer;
function InvalidateRect(AHandle: HWND; ARect: PRect; BErase: Boolean): Boolean;

resourcestring
  SNotImplemented = 'Not implemented';
  SUnsupportedPaintOperationType = 'Unsupported paint operation type';


implementation

uses
  NativePixelPointer;

function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer;
  Src: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
begin
  Result := BitBlt(Dest.Handle, X, Y, Width, Height, Src.Handle, XSrc, YSrc, Rop);
end;

function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer;
  Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY;
  Precise: Boolean = False): Boolean;
var
  SrcPixel: TPixelPointer;
  DstPixel: TPixelPointer;
  XX, YY: Integer;
  DstPixelX, DstPixelY: Integer;
  DstPixelWidth, DstPixelHeight: Integer;
begin
  if not Precise or (Frac(ScreenInfo.Dpi / 96) = 0) then begin
    // Use faster non-fractional scaling
    Result := BitBlt(Dest.Canvas.Handle, X, Y, Width, Height, Src.Canvas.Handle,
      XSrc, YSrc, Rop);
    Exit;
  end;

  if XSrc < 0 then begin
    X := X - XSrc;
    Width := Width - XSrc;
    XSrc := 0;
  end;
  if YSrc < 0 then begin
    Y := Y - YSrc;
    Height := Height - YSrc;
    YSrc := 0;
  end;

  if X < 0 then begin
    Width := Width + X;
    XSrc := XSrc - X;
    X := 0;
  end;
  if Y < 0 then begin
    Height := Height + Y;
    YSrc := YSrc - Y;
    Y := 0;
  end;
  if (X + Width) >= Dest.Width then begin
    Width := Dest.Width - X;
  end;
  if (Y + Height) >= Dest.Height then begin
    Height := Dest.Height - Y;
  end;
  if (Width < 0) or (Height < 0) then begin
    Result := True;
    Exit;
  end;

  Dest.BeginUpdate;
  SrcPixel := TPixelPointer.Create(Src.NativeBitmap);
  DstPixel := TPixelPointer.Create(Dest.NativeBitmap, ScaleToNative(X), ScaleToNative(Y));
  if Rop = SRCCOPY then begin
    for YY := 0 to Height - 1 do begin
      SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
      DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
      for DstPixelY := 0 to DstPixelHeight - 1 do begin
        for XX := 0 to Width - 1 do begin
          SrcPixel.SetX(ScaleToNative(XSrc + XX));
          DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
          for DstPixelX := 0 to DstPixelWidth - 1 do begin
            DstPixel.PixelRGB := SrcPixel.PixelARGB;
            DstPixel.NextPixel;
          end;
        end;
        DstPixel.NextLine;
      end;
    end;
  end else
  if Rop = SRCPAINT then begin
    for YY := 0 to Height - 1 do begin
      SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
      DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
      for DstPixelY := 0 to DstPixelHeight - 1 do begin
        for XX := 0 to Width - 1 do begin
          SrcPixel.SetX(ScaleToNative(XSrc + XX));
          DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
          for DstPixelX := 0 to DstPixelWidth - 1 do begin
            DstPixel.PixelRGB := DstPixel.PixelRGB or SrcPixel.PixelARGB;
            DstPixel.NextPixel;
          end;
        end;
        DstPixel.NextLine;
      end;
    end;
  end else
  if Rop = SRCAND then begin
    for YY := 0 to Height - 1 do begin
      SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
      DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
      for DstPixelY := 0 to DstPixelHeight - 1 do begin
        for XX := 0 to Width - 1 do begin
          SrcPixel.SetX(ScaleToNative(XSrc + XX));
          DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
          for DstPixelX := 0 to DstPixelWidth - 1 do begin
            DstPixel.PixelRGB := DstPixel.PixelRGB and SrcPixel.PixelARGB;
            DstPixel.NextPixel;
          end;
        end;
        DstPixel.NextLine;
      end;
    end;
  end else
  if Rop = DSTINVERT then begin
    for YY := 0 to Height - 1 do begin
      SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
      DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
      for DstPixelY := 0 to DstPixelHeight - 1 do begin
        for XX := 0 to Width - 1 do begin
          SrcPixel.SetX(ScaleToNative(XSrc + XX));
          DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
          for DstPixelX := 0 to DstPixelWidth - 1 do begin
            DstPixel.PixelRGB := not DstPixel.PixelRGB;
            DstPixel.NextPixel;
          end;
        end;
        DstPixel.NextLine;
      end;
    end;
  end else raise Exception.Create(SUnsupportedPaintOperationType);
  Dest.EndUpdate;
  Result := True;
end;

function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
begin
  Result := LCLIntf.CreateRectRgn(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2),
    ScaleToNative(Y2));
end;

{$IFDEF WINDOWS}
function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
  const lprcClip: RECT; hrgnUpdate: HRGN; lprcUpdate: LPRECT): WINBOOL;
var
  R: RECT;
begin
  if Assigned(lprcUpdate) then begin
    R := ScaleRectToNative(lprcUpdate^);
    lprcUpdate := @R;
  end;
  Result := Windows.ScrollDC(hDC, ScaleToNative(dx), ScaleToNative(dY),
    ScaleRectToNative(lprcScroll), ScaleRectToNative(lprcClip), hrgnUpdate, lprcUpdate);
end;
{$ENDIF}

function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint;
  const lprcScroll: TRect; const lprcClip: TRect; hrgnUpdate: HWND;
  lprcUpdate: PRect): Boolean;
begin
  {$IFDEF WINDOWS}
  Result := Windows.ScrollDC(Canvas.Handle, ScaleToNative(dx), ScaleToNative(dy),
    ScaleRectToNative(lprcScroll), ScaleRectToNative(lprcClip),
    hrgnUpdate, lprcUpdate);
  {$ENDIF}
  {$IFDEF LINUX}
  // Can't do scrolling of DC under Linux, then fallback into BitBlt.
  Result := BitBltCanvas(Canvas, lprcScroll.Left + dx, lprcScroll.Top + dy, lprcScroll.Right - lprcScroll.Left, lprcScroll.Bottom - lprcScroll.Top,
    Canvas, lprcScroll.Left, lprcScroll.Top);
  {$ENDIF}
end;

function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; X, Y, cx, cy: Integer;
  uFlags: UINT): Boolean;
begin
  Result := LCLIntf.SetWindowPos(hWnd, hWndInsertAfter, ScaleToNative(X), ScaleToNative(Y),
    ScaleToNative(cx), ScaleToNative(cy), uFlags);
end;

function ScaleToNative(Value: Integer): Integer; inline;
begin
  Result := ScreenInfo.LookupToNative[Value];
  // Round and Trunc are fast. Ceil and Floor are slow.
  // Without lookup table we would use:
  // Result := Ceil(Value * ScreenInfo.ToNative);
end;

function ScaleToNativeDist(Base, Value: Integer): Integer;
begin
  Result := ScaleToNative(Base + Value) - ScaleToNative(Base);
end;

function ScaleFromNative(Value: Integer): Integer;
begin
  Result := ScreenInfo.LookupFromNative[Value];
  // Round and Trunc are fast. Ceil and Floor are slow.
  // Without lookup table we would use:
  // Result := Floor(Value * ScreenInfo.FromNative);
end;

function ScalePointToNative(Value: TPoint): TPoint;
begin
  Result.X := ScaleToNative(Value.X);
  Result.Y := ScaleToNative(Value.Y);
end;

function ScalePointFromNative(Value: TPoint): TPoint;
begin
  Result.X := ScaleFromNative(Value.X);
  Result.Y := ScaleFromNative(Value.Y);
end;

function ScaleSizeToNative(Value: TSize): TSize;
begin
  Result.Width := ScaleToNative(Value.Width);
  Result.Height := ScaleToNative(Value.Height);
end;

function ScaleSizeFromNative(Value: TSize): TSize;
begin
  Result.Width := ScaleFromNative(Value.Width);
  Result.Height := ScaleFromNative(Value.Height);
end;

function ScaleRectToNative(Value: TRect): TRect;
begin
  Result.Left := ScaleToNative(Value.Left);
  Result.Top := ScaleToNative(Value.Top);
  Result.Right := ScaleToNative(Value.Right);
  Result.Bottom := ScaleToNative(Value.Bottom);
end;

function ScaleRectFromNative(Value: TRect): TRect;
begin
  Result.Left := ScaleFromNative(Value.Left);
  Result.Top := ScaleFromNative(Value.Top);
  Result.Right := ScaleFromNative(Value.Right);
  Result.Bottom := ScaleFromNative(Value.Bottom);
end;

function ScaleFloatToNative(Value: Double): Double;
begin
  Result := Value * ScreenInfo.ToNative;
end;

function ScaleFloatFromNative(Value: Double): Double;
begin
  Result := Value * ScreenInfo.FromNative;
end;

procedure WriteLog(Text: string);
var
  F: Text;
const
  FileName = 'Log.txt';
begin
  AssignFile(F, FileName);
  if FileExists(FileName) then Append(F) else Rewrite(F);
  WriteLn(F, Text);
  CloseFile(F);
end;

function GetSystemMetrics(nIndex: Integer): Integer;
begin
  Result := ScaleFromNative(LCLIntf.GetSystemMetrics(nIndex));
end;

function InvalidateRect(AHandle: HWND; ARect: PRect; BErase: Boolean): Boolean;
var
  NativeRect: TRect;
begin
  NativeRect := ScaleRectToNative(ARect^);
  Result := LCLIntf.InvalidateRect(AHandle, @NativeRect, BErase);
end;

function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
  YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
var
  DstWidth, DstHeight: Integer;
  SrcWidth, SrcHeight: Integer;
begin
  DstWidth := ScaleToNativeDist(X, Width);
  DstHeight := ScaleToNativeDist(Y, Height);
  SrcWidth := ScaleToNativeDist(XSrc, Width);
  SrcHeight := ScaleToNativeDist(YSrc, Height);

  if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin
    {$IFDEF WINDOWS}
    // On Windows LCLIntf.BitBlt is slower than direct Windows BitBlt
    Result := Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
      DstWidth, DstHeight, SrcDC,
      ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
    {$ELSE}
    Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
      DstWidth, DstHeight, SrcDC,
      ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
    {$ENDIF}
  end else begin
    {$IFDEF WINDOWS}
    // On Windows LCLIntf.BitBlt is slower than direct Windows BitBlt
    Result := Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
      Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
      ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);

    // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
    if DstWidth > SrcWidth then begin
      Windows.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
        DstWidth - SrcWidth, DstHeight, SrcDC,
        ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
    end;
    if DstHeight > SrcHeight then begin
      Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
        DstWidth, DstHeight - SrcHeight, SrcDC,
        ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
    end;
    {$ELSE}
    Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
      Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
      ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);

    // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
    if DstWidth > SrcWidth then begin
      LCLIntf.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
        DstWidth - SrcWidth, DstHeight, SrcDC,
        ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
    end;
    if DstHeight > SrcHeight then begin
      LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
        DstWidth, DstHeight - SrcHeight, SrcDC,
        ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
    end;
    {$ENDIF}
  end;
end;

end.