program NativeScrollDemo;
{$mode objfpc}{$H+}

uses
  Classes, windows, LazLogger;

var
  ScrollInfo: TScrollInfo;
  WndHandle: HWND;
  lastpos: integer;


function WindowWndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam) : LRESULT; stdcall;
var
  p: Word;
begin
  Result := 0;
  Case uMsg  Of
    WM_DESTROY : PostQuitMessage(0);
    WM_VSCROLL: begin
      p := HIWORD(LongInt(WParam));

      ScrollWindowEx(WndHandle, 0, lastpos - p, nil, nil, 0, nil,
        SW_INVALIDATE or
        SW_ERASE or
        SW_SCROLLCHILDREN
      );
      lastpos := p;

      //ScrollInfo.cbSize := SizeOf(ScrollInfo);
      //ScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL and not SIF_TRACKPOS;
      //ScrollInfo.nMin := 1;
      //ScrollInfo.nTrackPos := p;
      //ScrollInfo.nMax := 3000;
      //SetScrollInfo(WndHandle, SB_VERT, ScrollInfo, False);

      Result := 0;
    end;
    Else
      Result := Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
  End;
end;



procedure ShowWindow;
Var
  A_Atom : TAtom = 0;
  WndClass : TWndClass;
  Msg: TMsg;
  ScreenWidth, ScreenHeight, MiddleX, MiddleY : LongInt;
  i, j: Integer;
Begin
  lastpos := 0;
  FillChar(WndClass, SizeOf(TWndClass), 0);

  ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
  ScreenHeight := GetSystemMetrics(SM_CYSCREEN);

  MiddleX := (ScreenWidth - 500) Div 2;
  MiddleY := (ScreenHeight - 500) div 2;

  WndClass.lpszClassName:= 'HEAPTRACE_CLASS';
  WndClass.lpfnWndProc :=  @WindowWndProc;

  WndClass.hInstance := hInstance;
  WndClass.hbrBackground:= 1;
  WndClass.style := CS_HREDRAW or CS_VREDRAW;
  WndClass.hCursor := LoadCursor(0, IDC_ARROW);

  A_Atom := RegisterClass(WndClass);

  WndHandle := CreateWindow(
   WndClass.lpszClassName , // lpClassName, optional
   'Foo',
   WS_OVERLAPPEDWINDOW or WS_VISIBLE or WS_VSCROLL , // dwStyle
   MiddleX, // x
   MiddleY, // y
   500, // nWidth
   500, // nHeight
   0, // hWndParent
   0, // hMenu
   WndClass.hInstance, // hInstance
   nil  // lpParam
   );


  ScrollInfo.cbSize := SizeOf(ScrollInfo);
  ScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL and not SIF_TRACKPOS;
  ScrollInfo.nMin := 1;
  ScrollInfo.nTrackPos := 0;
  ScrollInfo.nMax := 3000;
  SetScrollInfo(WndHandle, SB_VERT, ScrollInfo, False);


for i := 0 to 50 do
for j := 0 to 3 do begin
  CreateWindow(
   'BUTTON' , // lpClassName, optional
   'OK', // lpWindowName, optional
   WS_TABSTOP or WS_VISIBLE or WS_CHILD or BS_DEFPUSHBUTTON , // dwStyle
   20 + j * 60, // x
   40 + i * 60, // y
   50, // nWidth
   50, // nHeight
   WndHandle, // hWndParent
   0, // hMenu
   WndClass.hInstance, // hInstance
   nil  // lpParam
   );
end;

  BringWindowToTop(WndHandle);

  while GetMessage(Msg,0,0,0) do begin
//DbgOut(',');
    DispatchMessage(Msg);
  end;

  DestroyWindow(WndHandle);

  UnregisterClass(WndClass.lpszClassName, WndClass.hInstance);
end;


begin
  ShowWindow;
end.

program NativeScrollDemo;

// https://bugs.freepascal.org/view.php?id=37463

{$mode objfpc}{$H+}

{.$DEFINE UseLogger}

uses
  SysUtils, Classes, Windows
  {$IFDEF UseLogger},
  LazLogger,
  WineMessages, gist_1_WM_Messages
  {$ENDIF UseLogger}
  ;

const
  PM_QS_INPUT = QS_INPUT shl 16; // Process mouse and keyboard messages.
  PM_QS_PAINT = QS_PAINT shl 16; // Process paint messages.
  { Process all posted messages, including timers and hotkeys. }
  PM_QS_POSTMESSAGE = (QS_POSTMESSAGE or QS_HOTKEY or QS_TIMER) shl 16;
  PM_QS_SENDMESSAGE = QS_SENDMESSAGE shl 16; // Process all sent messages.

var
  ScrollInfo: TScrollInfo;
  WndHandle: HWND;
  lastpos: integer;
  cPainting : boolean = false;

const
  cNbRows = 100;
  cNbColumns = 5;
  cMsgCounter : integer = -1;

{$IFDEF UseLogger},
function WineMsgStr(aMsg : UINT) : string;
var
  lWineStr : string;
begin
  Result := '';
  repeat
    lWineStr := GetWineWindMsgName(aMsg);
    if lWineStr<>'' then
      if Result <> '' then
        Result := Result + ',' + lWineStr
      else
        Result := lWineStr;
  until lWineStr = '';
end;
{$ENDIF UseLogger}

  function WindowWndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam;
    lParam: LParam): LRESULT; stdcall;

  var
    p: word;
    TextBuf : shortstring;
    TextLen : integer;
    lMsg: TMsg;
  label
    ExitProc;
  begin
    if uMsg = WM_GETTEXT then begin
      Result := Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
      Exit;
    end;
    {$IFDEF UseLogger} DebugLnEnter;{$ENDIF UseLogger}
    if uMsg = WM_PAINT then
      cPainting := True;
    Result := 0;
    {$IFDEF UseLogger}
    Inc(cMsgCounter);
    if uMsg <> WM_NCMOUSEMOVE then begin
      DbgOut('WindowWndProc;');
      TextLen := GetWindowTextA(Ahwnd, @TextBuf[1], 255);
      SetLength(TextBuf, TextLen);
      DbgOut(TextBuf);
      DebugLn(';',IntToStr(cMsgCounter),';',IntToStr(Ahwnd),';',IntToStr(uMsg),';',
              IntToStr(wParam),';',HexStr(Pointer(lParam)),';',
              WineMsgStr(uMsg));
    end;
    {$ENDIF UseLogger}
    if cPainting and (uMsg = WM_VSCROLL) then begin
      cPainting := PeekMessage(lMsg, 0, 0, 0, PM_QS_PAINT or PM_NOREMOVE);
      if cPainting then begin
        {$IFDEF UseLogger} DebugLn('-> discarded');{$ENDIF UseLogger}
        goto
          ExitProc;
      end;
    end;
    case uMsg of
      WM_DESTROY: PostQuitMessage(0);
      WM_VSCROLL:
        begin
          p := HIWORD(longint(WParam));

          ScrollWindowEx(WndHandle, 0, lastpos - p, nil, nil, 0, nil,
            SW_INVALIDATE or SW_ERASE or SW_SCROLLCHILDREN
            );
          lastpos := p;

          //ScrollInfo.cbSize := SizeOf(ScrollInfo);
          //ScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL and not SIF_TRACKPOS;
          //ScrollInfo.nMin := 1;
          //ScrollInfo.nTrackPos := p;
          //ScrollInfo.nMax := 3000;
          //SetScrollInfo(WndHandle, SB_VERT, ScrollInfo, False);

          Result := 0;
        end
      else
        Result := Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
    end;
  ExitProc:
    {$IFDEF UseLogger} DebugLnExit; {$ENDIF UseLogger}

  end;


  procedure ShowWindow;
  var
    A_Atom: TAtom = 0;
    WndClass: TWndClass;
    Msg: TMsg;
    ScreenWidth, ScreenHeight, MiddleX, MiddleY: longint;
    i, j: integer;
    GMResult : BOOL;
    lBtnLabel : string;
    TextBuf : shortstring;
    TextLen : integer;
  begin
    lastpos := 0;
    FillChar(WndClass, SizeOf(TWndClass), 0);

    ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
    ScreenHeight := GetSystemMetrics(SM_CYSCREEN);

    MiddleX := (ScreenWidth - 500) div 2;
    MiddleY := (ScreenHeight - 500) div 2;

    WndClass.lpszClassName := 'HEAPTRACE_CLASS';
    WndClass.lpfnWndProc := @WindowWndProc;

    WndClass.hInstance := hInstance;
    WndClass.hbrBackground := 1;
    WndClass.style := CS_HREDRAW or CS_VREDRAW;
    WndClass.hCursor := LoadCursor(0, IDC_ARROW);

    A_Atom := RegisterClass(WndClass);

    WndHandle := CreateWindow(WndClass.lpszClassName, // lpClassName, optional
      'Foo', WS_OVERLAPPEDWINDOW or WS_VISIBLE or WS_VSCROLL, // dwStyle
      MiddleX, // x
      MiddleY, // y
      500, // nWidth
      500, // nHeight
      0, // hWndParent
      0, // hMenu
      WndClass.hInstance, // hInstance
      nil  // lpParam
      );


    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL and not SIF_TRACKPOS;
    ScrollInfo.nMin := 0;
    ScrollInfo.nTrackPos := 0;
    ScrollInfo.nMax := cNbRows * 56; // Dont ask me why ~bk
    SetScrollInfo(WndHandle, SB_VERT, ScrollInfo, False);

    for i := 0 to cNbRows - 1 do
      for j := 0 to cNbColumns - 1 do begin
        lBtnLabel := Format('OK [%2d,%2d]', [i,j]);
        CreateWindow(
          'BUTTON', // lpClassName, optional
          @lBtnLabel[1],
          // 'OK ', // lpWindowName, optional
          WS_TABSTOP or WS_VISIBLE or WS_CHILD or BS_DEFPUSHBUTTON, // dwStyle
          20 + j * 90, // x
          40 + i * 60, // y
          80, // nWidth
          50, // nHeight
          WndHandle, // hWndParent
          0, // hMenu
          WndClass.hInstance, // hInstance
          nil  // lpParam
          );
      end;

    BringWindowToTop(WndHandle);

    repeat
      GMResult := GetMessage(Msg, 0, 0, 0);
      Inc(cMsgCounter);
      if not GMResult then begin
        WriteLn;
        break;
      end;
      {$IFDEF UseLogger}
      DbgOut('ShowWindow;');
      TextLen := GetWindowTextA(Msg.hwnd, @TextBuf[1], 255);
      SetLength(TextBuf, TextLen);
      DbgOut(TextBuf);
      DebugLn(';',IntToStr(cMsgCounter),';',IntToStr(Msg.hwnd),';',
              IntToStr(Msg.message),';',
              IntToStr(Msg.wParam),';',HexStr(Pointer(Msg.lParam)),';',
              WineMsgStr(Msg.message));
      {$ENDIF UseLogger}
      {
      if Msg.message = WM_PAINT then begin
        cPainting := True;
        repeat
          DispatchMessage(Msg);
        until not PeekMessage(Msg, 0, 0, 0, PM_QS_PAINT or PM_REMOVE);
        cPainting := False;
      end
      else
      }
      DispatchMessage(Msg);
      cPainting := False;
    until False;

    DestroyWindow(WndHandle);

    UnregisterClass(WndClass.lpszClassName, WndClass.hInstance);
  end;


begin
  ShowWindow;
  Write('Enter to quit > ');ReadLn;
end.