更新：解决方案

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;

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

更新：解决方案

  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，然后滚动GridX，反过来...... SO。您可以通过用标志包围块来保护表面滚动代码。

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。

<小时/> 修改：

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的变化，而不会另一个......

我的意思是完全工作，因为它不依赖于做什么......

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

它与消息没有任何关系，但是因为我试图通过捕获消息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用户正在行动...无论用户做什么，移动鼠标并选择文本，按左，右，主页，结束键，使用鼠标水平轮（不是都有一个），拖动滚动条，按任意部分水平滚动条等...

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

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

在你的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;

下一部分是对新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 jsut配置一点配置，让它完美运行：

让两个TMemo滚动条都可见
让两个Tmemo上的WordWrap为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

我找到了一个解决方案...我知道它非常棘手......但至少它是完全正常的...

而不是试图隐藏水平滚动条...我将它显示在可见区域之外，因此用户无法看到...

棘手的部分：

将TPanel放在TMemo所在的位置，并将TMemo放在TPanel
隐藏TPanel边框，将BorderWith设为0，将所有斜角设为bvNone / bkNone
配置TMemo与alTop对齐，而不是alClient等...
处理TPanel.OnResize使TMemo.Height大于TPanel.Height和水平滚动条高度一样多（当下我使用20像素的常量值，但我想知道如何获得真正的值）< / LI>

就是这样......完成了！水平滚动条超出了可见区域...你可以放在你想要的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;

Thas是人们！我知道它非常棘手，但功能齐全。

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

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

Answer 5

感谢您GetSystemMetrics和SM_CYHSCROLL，但它不仅仅是......还需要3个像素......

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

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

非常感谢。

如果你喜欢，只需将它们加入一个Big帖子，但我认为最好不要将它们混合在一起。

回答“Sertac Akyuz”（抱歉在这里做，但我不知道如何在你的问题旁边张贴）：

我把我发现的解决方案放在这里......我的意图是不要把它用作刮刮板......我在撰写帖子之前的时间点丢失了解决方案
我认为最好看旧帖子，而不是编辑繁殖时间只是相同的帖子...它也不会让其他人知道确切的解决方案，也会让他们知道如何达成这样的解决方案。
我喜欢以“教导如何捕鱼，而不是给予它”的方式做事鱼”。
我没有打开一个新问题只是因为这个问题的标题与我想要做的完全相同

重要：我发现无法通过邮件捕获完成一个完美的解决方案，因为有一种情况会导致滚动但没有消息WM_VSCROLL，WM_HSCROLL（仅{ {1}}）...它与用鼠标选择文本有关...让我解释一下我是如何看待它的......在最后一条视线的末端附近开始并稍微向下移动鼠标，然后停止鼠标移动并按下鼠标按钮...没有做任何事情（鼠标不移动，没有键盘，没有键盘，没有鼠标按钮更改等等）TMemo向下滚动直到文本结束...当鼠标靠近视线的右端并向右移动时，水平滚动也会发生同样的情况......在相反的方向也是如此...这样的滚动不通过消息WM_PAINT WM_VSCROLL，只有{{1 （至少在我的电脑上）......在网格上也是如此。

同步滚动组件Delphi

更新：解决方案

5 个答案: