Delphi 同步滚动组件

Question

我正在尝试同步 VCL Forms 应用程序中两个 TDBGrid 组件的滚动，但在没有堆栈问题的情况下拦截每个网格组件的 WndProc 时遇到困难。我尝试在滚动事件下发送 WM_VSCROLL 消息，但这仍然导致错误的操作。它需要用于单击滚动条、突出显示单元格或向上或向下鼠标按钮。整个想法是让两个相邻的网格显示一种匹配的对话框。

尝试过

SendMessage( gridX.Handle, WM_VSCROLL, SB_LINEDOWN, 0 );

也

procedure TForm1.GridXCustomWndProc( var Msg: TMessage );
begin
Msg.Result := CallWindowProc( POldWndProc, gridX.Handle, Msg.Msg, Msg.wParam, Msg.lParam );

   if ( Msg.Msg = WM_VSCROLL ) then 
   begin
      gridY.SetActiveRow( gridX.GetActiveRow );
      gridY.Perform( Msg.Msg, Msg.wParam, Msg.lParam );
      SetScrollPos( gridY.Handle, SB_VERT, HIWORD( Msg.wParam ), True );
   end;
end;

并且

procedure TForm1.GridxCustomWndProc( var Msg: TMessage );
begin
   if ( Msg.Msg = WM_VSCROLL ) then 
   begin
      gridY.SetActiveRow( gridX.GetActiveRow );
      gridY.Perform( Msg.Msg, Msg.wParam, Msg.lParam );
      SetScrollPos( gridY.Handle, SB_VERT, HIWORD( Msg.wParam ), True );
   end;
   inherited WndProc( Msg );
end;

第一个只是一个临时解决方案，第二个导致无效的内存读取，第三个导致堆栈溢出。所以这些解决方案似乎都不适合我。我希望获得一些关于如何完成这项任务的意见！提前致谢。

更新：解决方案

  private
    [...]
    GridXWndProc, GridXSaveWndProc: Pointer;
    GridYWndProc, GridYSaveWndProc: Pointer;
    procedure GridXCustomWndProc( var Msg: TMessage );
    procedure GridYCustomWndProc( var Msg: TMessage );

procedure TForm1.FormCreate(Sender: TObject);
begin
  GridXWndProc := classes.MakeObjectInstance( GridXCustomWndProc );
  GridXSaveWndProc := Pointer( GetWindowLong( GridX.Handle, GWL_WNDPROC ) );
  SetWindowLong( GridX.Handle, GWL_WNDPROC, LongInt( GridXWndProc ) );

  GridYWndProc := classes.MakeObjectInstance( GridYCustomWndProc );
  GridYSaveWndProc := Pointer( GetWindowLong( GridY.Handle, GWL_WNDPROC ) );
  SetWindowLong( GridY.Handle, GWL_WNDPROC, LongInt( GridYWndProc ) );
end;

procedure TForm1.GridXCustomWndProc( var Msg: TMessage );
begin
   Msg.Result := CallWindowProc( GridXSaveWndProc, GridX.Handle, Msg.Msg, Msg.WParam, Msg.LParam );
   case Msg.Msg of
      WM_KEYDOWN:
      begin
         case TWMKey( Msg ).CharCode of VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT:
            GridY.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
         end;
      end;
      WM_VSCROLL:
         GridY.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      WM_HSCROLL:
         GridY.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      WM_MOUSEWHEEL:
      begin
         ActiveControl := GridY;
         GridY.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      end;
      WM_DESTROY:
      begin
         SetWindowLong( GridX.Handle, GWL_WNDPROC, Longint( GridXSaveWndProc ) );
         Classes.FreeObjectInstance( GridXWndProc );
      end;
  end;
end;

procedure TForm1.GridXMouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
   GridY.SetActiveRow( GridX.GetActiveRow );
end;

procedure TForm1.GridYCustomWndProc( var Msg: TMessage );
begin
   Msg.Result := CallWindowProc( GridYSaveWndProc, GridY.Handle, Msg.Msg, Msg.WParam, Msg.LParam );
   case Msg.Msg of
      WM_KEYDOWN:
      begin
         case TWMKey( Msg ).CharCode of VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT:
            GridX.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
         end;
      end;
      WM_VSCROLL:
         GridX.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      WM_HSCROLL:
         GridX.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      WM_MOUSEWHEEL:
      begin
         ActiveControl := GridX;
         GridX.Perform( Msg.Msg, Msg.WParam, Msg.LParam );
      end;
      WM_DESTROY:
      begin
         SetWindowLong( GridY.Handle, GWL_WNDPROC, Longint( GridYSaveWndProc ) );
         Classes.FreeObjectInstance( GridYWndProc );
      end;
   end;
end;

procedure TForm1.GridYMouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
   GridX.SetActiveRow( GridY.GetActiveRow );
end;

感谢 - Sertac Akyuz 提供的解决方案。当使用网格集成到 VCL 表单应用程序中时，它们将在滚动和突出显示所选记录方面相互模仿。

Answer 1

您可能正在为两个网格实现消息覆盖。 GridX 滚动 GridY，GridY 又滚动 GridX，GridX 又滚动……所以。您可以通过用标志包围块来保护表面滚动代码。

type
  TForm1 = class(TForm)
    [..] 
  private
    FNoScrollGridX, FNoScrollGridY: Boolean;
    [..]

procedure TForm1.GridXCustomWndProc( var Msg: TMessage );
begin
  Msg.Result := CallWindowProc(POldWndProc, gridX.Handle, Msg.Msg, Msg.wParam, Msg.lParam );

  if ( Msg.Msg = WM_VSCROLL ) then 
  begin
    if not FNoScrollGridX then
    begin
      FNoScrollGridX := True
      gridY.SetActiveRow( gridX.GetActiveRow );
      gridY.Perform( Msg.Msg, Msg.wParam, Msg.lParam );
//      SetScrollPos( gridY.Handle, SB_VERT, HIWORD( Msg.wParam ), True );
    end;
    FNoScrollGridX := False;
  end;
end;

GridY 的类似代码。顺便说一句，您不应该需要 SetScrollPos。

---

edit:

TForm1 = class(TForm)
  [..]
private
  GridXWndProc, GridXSaveWndProc: Pointer;
  GridYWndProc, GridYSaveWndProc: Pointer;
  procedure GridXCustomWndProc(var Msg: TMessage);
  procedure GridYCustomWndProc(var Msg: TMessage);
  [..]

procedure TForm1.FormCreate(Sender: TObject);
begin
  [..]

  GridXWndProc := classes.MakeObjectInstance(GridXCustomWndProc);
  GridXSaveWndProc := Pointer(GetWindowLong(GridX.Handle, GWL_WNDPROC));
  SetWindowLong(GridX.Handle, GWL_WNDPROC, LongInt(GridXWndProc));

  GridYWndProc := classes.MakeObjectInstance(GridYCustomWndProc);
  GridYSaveWndProc := Pointer(GetWindowLong(GridY.Handle, GWL_WNDPROC));
  SetWindowLong(GridY.Handle, GWL_WNDPROC, LongInt(GridYWndProc));
end;

procedure TForm1.GridXCustomWndProc(var Msg: TMessage);
begin
  Msg.Result := CallWindowProc(GridXSaveWndProc, GridX.Handle,
      Msg.Msg, Msg.WParam, Msg.LParam);

  case Msg.Msg of
    WM_KEYDOWN:
      begin
        case TWMKey(Msg).CharCode of
          VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT:
            GridY.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
        end;
      end;
    WM_VSCROLL: GridY.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
    WM_MOUSEWHEEL:
      begin
        ActiveControl := GridY;
        GridY.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
      end;
    WM_DESTROY:
      begin
        SetWindowLong(GridX.Handle, GWL_WNDPROC, Longint(GridXSaveWndProc));
        Classes.FreeObjectInstance(GridXWndProc);
      end;
  end;
end;

procedure TForm1.GridYCustomWndProc(var Msg: TMessage);
begin
  Msg.Result := CallWindowProc(GridYSaveWndProc, GridY.Handle,
      Msg.Msg, Msg.WParam, Msg.LParam);

  case Msg.Msg of
    WM_KEYDOWN:
      begin
        case TWMKey(Msg).CharCode of
          VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT:
            GridX.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
        end;
      end;
    WM_VSCROLL: GridX.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
    WM_MOUSEWHEEL:
      begin
        ActiveControl := GridX;
        GridY.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
      end;
    WM_DESTROY:
      begin
        SetWindowLong(GridY.Handle, GWL_WNDPROC, Longint(GridYSaveWndProc));
        Classes.FreeObjectInstance(GridYWndProc);
      end;
  end;
end;

Answer 2

我得到了部分但现在完整工作的解决方案（至少对于两个 TMemo）...

我的意思是部分的，因为它只监听一个 TMemo 上的更改，但不监听另一个 TMemo...

我的意思是完全工作，因为它不依赖于关于所做的事情...

就像在一个备忘录上放置相同的水平滚动值一样简单，就像在另一个备忘录上一样...

它与消息无关，但因为我试图通过捕获消息来获得工作解决方案WM_HSCROLL 等...我留下了代码，因为它有效...我稍后会尝试改进它...例如仅捕获 WM_PAINT，或以其他方式...但现在，我将其按我所拥有的方式放置因为它有效...而且我没有找到更好的东西...

这是有效的代码：

// On private section of TForm1
Memo_OldWndProc:TWndMethod; // Just to save and call original handler
procedure Memo_NewWndProc(var TheMessage:TMessage); // New handler

// On implementation section of TForm1    
procedure TForm1.FormCreate(Sender: TObject);
begin
     Memo_OldWndProc:=Memo1.WindowProc; // Save the handler
     Memo1.WindowProc:=Memo_NewWndProc; // Put the new handler, so we can do extra things
end;

procedure TForm1.Memo_NewWndProc(var TheMessage:TMessage);
begin
     Memo_OldWndProc(TheMessage); // Let the scrollbar to move to final position
     Memo2.Perform(WM_HSCROLL
                  ,SB_THUMBPOSITION+65536*GetScrollPos(Memo1.Handle,SB_HORZ)
                  ,0
                  ); // Put the horizontal scroll of Memo2 at same position as Memo1
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
     Memo1.WindowProc:=Memo_OldWndProc; // Restore the old handler
end;

它适用于使滚动改变的所有方法...

注释：

• 我知道捕获所有内容是可怕的消息，但至少有效...
• 这是我第一次成功尝试同步两个 TMemos
  水平滚动条...
• 所以，如果有人可以稍微改进一下（不要捕获所有消息）
  做并发布它。
• 它只会使 Memo1 与 Memo2 栏水平同步，但不会
  Memo2 与 Memo1 同步 按
• 上、下、左、右、鼠标滚轮等键...无论您如何
  想要但在 Memo2 上看到它的运行情况，

我将尝试通过以下方式改进它：在 Memo2 上执行某些操作时，Memo1 滚动仍然同步...

我认为它可以适用于几乎所有具有 ScrollBar 的控件，而不仅仅是 TMemo。 ..

Answer 3

正如我所说...

在效率、干净的代码和双向方面，这是一个更好的解决方案（不是最终的解决方案）...对任何一个的更改都会影响另一个...

请阅读代码注释以了解什么每个句子都是...这很棘手...但主要思想与之前相同...设置另一个 TMemo 水平滚动条，因为它位于用户正在操作的 TMemo 上...无论什么用户是的，移动鼠标并选择文本，按向左、向右、home、结束键，使用鼠标水平滚轮（并非所有都有），拖动滚动条，按水平滚动条的任何部分等...

主要思想是...该对象需要重新绘制，所以然后将另一个对象水平滚动条与此相同...

第一部分只是向 TMemo 类添加内容，它只是创建一个新的派生类，但使用相同的类名，但仅适用于声明的单元。

将其添加到 TForm 声明之前的接口部分，这样您的 TForm 将看到这个新的 TMemo 类而不是普通的 TMemo 类：

type
    TMemo=class(StdCtrls.TMemo) // Just to add things to TMemo class only for this unit
    private
       BusyUpdating:Boolean; // To avoid circular stack overflow
       SyncMemo:TMemo; // To remember the TMemo to be sync
       Old_WindowProc:TWndMethod; // To remember old handler
       procedure New_WindowProc(var Mensaje:TMessage); // The new handler
    public
       constructor Create(AOwner:TComponent);override; // The new constructor
       destructor Destroy;override; // The new destructor
    end;

下一部分是该新 TMemo 类的先前声明的实现。

将其添加到您喜欢的任何地方的实现部分：

constructor TMemo.Create(AOwner:TComponent); // The new constructor
begin
     inherited Create(AOwner); // Call real constructor
     BusyUpdating:=False; // Initialize as not being in use, to let enter
     Old_WindowProc:=WindowProc; // Remember old handler
     WindowProc:=New_WindowProc; // Replace handler with new one
end;

destructor TMemo.Destroy; // The new destructor
begin
     WindowProc:=Old_WindowProc; // Restore the original handler
     inherited Destroy; // Call the real destructor
end;

procedure TMemo.New_WindowProc(var Mensaje:TMessage);
begin
     Old_WindowProc(Mensaje); // Call the real handle before doing anything
     if  BusyUpdating // To avoid circular stack overflow
       or
         (not Assigned(SyncMemo)) // If not yet set (see TForm1.FormCreate bwlow)
       or
         (WM_PAINT<>Mensaje.Msg) // If not when need to be repainted to improve speed
     then Exit; // Do no more and exit the procedure
     BusyUpdating:=True; // Set that object is busy in our special action
     SyncMemo.Perform(WM_HSCROLL,SB_THUMBPOSITION+65536*GetScrollPos(Handle,SB_HORZ),0); // Send to the other TMemo a message to set its horizontal scroll as it is on this TMemo
     BusyUpdating:=False; // Set that the object is no more busy in our special action
end;

现在是最后一部分，告诉每个 TMemo 必须同步的其他备忘录是什么。

在您的实现部分，为 Form1 Create 事件添加如下内容：

procedure TForm1.FormCreate(Sender: TObject);
begin
     Memo1.SyncMemo:=Memo2; // Tell Memo1 what TMemo must sync (Memo2)
     Memo2.SyncMemo:=Memo1; // Tell Memo2 what TMemo must sync (Memo1)
end;

请记住，我们已将 SyncMemo 成员添加到我们特殊的新 TMemo 类中，它的存在就是为了这个，告诉彼此哪个是另一个。

现在，对两个 TMemo 进行一些配置，让其完美运行：

• 让两个 TMemo 滚动条都可见
• 让 WordWrap 在两个 Tmemo 上都为 false
• 放置大量文本（两者相同）、长行和大量行

运行它并查看两个水平滚动条如何始终同步...

• 如果移动一个水平滚动条，则移动另一个水平滚动条
  移动...
• 如果您将文本移动到右侧或左侧、行首或行尾，
  等等......，无论SelStart在另一个......水平方向上
  文本滚动已同步。

为什么这不是最终版本的问题是：

• 滚动条（在我的例子中是水平滚动条）无法隐藏...因为如果隐藏滚动条，则在调用 GetScrollPos 时它会返回零，因此使其不同步。

如果有人知道如何模拟隐藏或使 GetScrollPos 不返回零，请发表评论，这是我需要为最终版本修复的唯一问题。

注意：

• 显然垂直滚动条也可以做同样的事情......只需更改
  WM_HSCROLL 到 WM_VSCROLL，SB_HORZ 到 SB_VERT
• 显然，可以同时对两者进行相同的操作...只需复制 SyncMemo.Perform 行两次，一次让 WM_HSCROLL 和 SB_HORZ，另一次让 WM_VSCROLL 和 SB_VERT

这是一个示例New_WindowProc程序用于同时同步两个滚动条，也许适合懒人，也许适合喜欢复制粘贴的人：

procedure TMemo.New_WindowProc(var Mensaje:TMessage);
begin
     Old_WindowProc(Mensaje); // Call the real handle before doing anything
     if  BusyUpdating // To avoid circular stack overflow
       or
         (not Assigned(SyncMemo)) // If not yet set (see TForm1.FormCreate bwlow)
       or
         (WM_PAINT<>Mensaje.Msg) // If not when need to be repainted to improve speed
     then Exit; // Do no more and exit the procedure
     BusyUpdating:=True; // Set that object is busy in our special action
     SyncMemo.Perform(WM_HSCROLL,SB_THUMBPOSITION+65536*GetScrollPos(Handle,SB_HORZ),0); // Send to the other TMemo a message to set its horizontal scroll as it is on this TMemo
     SyncMemo.Perform(WM_VSCROLL,SB_THUMBPOSITION+65536*GetScrollPos(Handle,SB_VERT),0); // Send to the other TMemo a message to set its vertical scroll as it is on this TMemo
     BusyUpdating:=False; // Set that the object is no more busy in our special action
end;

希望有人能解决隐藏一个滚动条和GetScrollPos返回零的问题！

Answer 4

我找到了一个解决方案...我知道这很棘手...但至少它功能齐全...

而不是试图隐藏水平滚动条...我让它显示在可见区域之外，所以用户看不到...

棘手的部分：

• 在 TMemo 所在的位置放置一个 TPanel，并将 TMemo 放在 TPanel 内
• 隐藏 TPanel 边框，将 BorderWith 设置为 0，并将所有 Bevel 设为 bvNone/bkNone
• 配置 TMemo 与 alTop 对齐，不是 alClient 等...
• 处理 TPanel.OnResize 以使 TMemo.Height 大于 TPanel.Height 与水平滚动条高度一样多（此时我使用 20 像素的常量值，但我想知道如何获取真正的价值）

就是这样......完成！水平滚动条不在可见区域...您可以将 TPanel 放在您想要的位置，给它您想要的大小...用户不会看到水平滚动条并且它不会隐藏，因此 GetScrollPos 将正常工作...我知道这很棘手，但功能齐全。

以下是存档的完整代码：

在接口部分，在 TForm 声明之前，因此您的 TForm 将看到这个新的 TMemo 类，而不是普通的类：

type
    TMemo=class(StdCtrls.TMemo) // Just to add things to TMemo class only for this unit
    private
       BusyUpdating:Boolean; // To avoid circular stack overflow
       SyncMemo:TMemo; // To remember the TMemo to be sync
       Old_WindowProc:TWndMethod; // To remember old handler
       procedure New_WindowProc(var Mensaje:TMessage); // The new handler
    public
       constructor Create(AOwner:TComponent);override; // The new constructor
       destructor Destroy;override; // The new destructor
    end;

在您喜欢的任何地方的实现部分：

constructor TMemo.Create(AOwner:TComponent); // The new constructor
begin
     inherited Create(AOwner); // Call real constructor
     BusyUpdating:=False; // Initialize as not being in use, to let enter
     Old_WindowProc:=WindowProc; // Remember old handler
     WindowProc:=New_WindowProc; // Replace handler with new one
end;

destructor TMemo.Destroy; // The new destructor
begin
     WindowProc:=Old_WindowProc; // Restore the original handler
     inherited Destroy; // Call the real destructor
end;

procedure TMemo.New_WindowProc(var Mensaje:TMessage);
begin
     Old_WindowProc(Mensaje); // Call the real handle before doing anything
     if  (WM_PAINT<>Mensaje.Msg) // If not when need to be repainted to improve speed
       or
         BusyUpdating // To avoid circular stack overflow
       or
         (not Assigned(SyncMemo)) // If not yet set (see TForm1.FormCreate bwlow)
     then Exit; // Do no more and exit the procedure
     BusyUpdating:=True; // Set that object is busy in our special action
     SyncMemo.Perform(WM_HSCROLL,SB_THUMBPOSITION+65536*GetScrollPos(Handle,SB_HORZ),0); // Send to the other TMemo a message to set its horizontal scroll as it is on this TMemo
     BusyUpdating:=False; // Set that the object is no more busy in our special action
end;

在您喜欢的任何地方的实现部分：

procedure TForm1.FormCreate(Sender: TObject);
begin
     Memo1.SyncMemo:=Memo2; // Tell Memo1 what TMemo must sync (Memo2)
     Memo2.SyncMemo:=Memo1; // Tell Memo2 what TMemo must sync (Memo1)
end;

procedure TForm1.pnlMemo2Resize(Sender: TObject);
begin
     Memo2.Height:=pnlMemo2.Height+20; // Make height enough big to cause horizontal scroll bar be out of TPanel visible area, so it will not be seen by the user
end;

就是这样，伙计们！我知道这很棘手，但功能齐全。

请注意，我在 New_WindowProc 上更改了评估 OR 条件的顺序...这只是为了提高所有其他消息的速度，因此尽可能少地延迟所有消息处理。

希望有一天我会知道如何用真实的（计算或读取的）TMemo 水平滚动条高度替换这样的 20。

Answer 5

感谢 GetSystemMetrics 和 SM_CYHSCROLL，但这还不够...只需要多 3 个像素...

所以我只使用：GetSystemMetrics(SM_CYHSCROLL)+ 3

注意：其中两个像素可能是因为父面板的 BevelWidth 值为 1，但我有 BevelInner 和 BevelOuter 的值为 bvNone 所以可能不会；但额外的像素我不知道为什么。

多谢。

如果您愿意，可以将它们加入到一篇大帖子中，但我认为最好不要混合它们。

回答“Sertac Akyuz”（很抱歉在这里这样做，但我不知道如何将它们发布在你的问题旁边）：

• 我把我找到的解决方案放在这里......我的意图是
  不要将它用作便签本...我在写帖子之前几秒钟就发现了解决方案
• 我认为最好查看旧帖子，而不是编辑乘法
  多次同一个帖子...它也不会让其他人知道确切的解决方案，
  也会让他们知道如何达成这样的解决方案。
• 我更喜欢以“授之以鱼，授之以渔”的方式做事
  我没有提出一个新问题，
• 只是因为这个问题的标题正是我想要做的

重要：我发现通过消息捕获无法完成完美的解决方案，因为有是一种导致滚动但没有消息WM_VSCROLL、WM_HSCROLL（仅WM_PAINT）的情况...它与用鼠标选择文本有关。让我解释一下我如何看待它的实际效果...只需在最后一条视线的末端附近开始并将鼠标向下移动一点，然后停止鼠标移动并按下鼠标按钮...不执行任何操作（鼠标不移动） ，没有按键，没有按键，没有鼠标按钮更改等...）TMemo 向下滚动直到到达文本末尾...当鼠标靠近视线右端并向右移动时，水平滚动也会发生同样的情况...相反方向也相同...此类滚动不通过消息 WM_VSCROLL WM_HSCROLL，仅通过 WM_PAINT （至少在我的计算机上） ...同样的情况也发生在网格上。