5

我正在尝试在 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 表单应用程序中时，它们将在滚动和突出显示所选记录时相互模仿。

4

5 回答 5

3

您可能正在为两个网格实现消息覆盖。GridX 滚动 GridY，后者又滚动 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。

编辑：

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;
于 2010-07-21T19:58:58.513 回答
3

我得到了一个部分但现在完整的解决方案（至少对于两个 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 ......
  • 因此，如果有人可以对其进行一些改进（而不是捕获所有消息），请执行并发布。
  • 它只使备忘录 1 与备忘录 2 条水平同步，而不使备忘录 2 与备忘录 1 同步
  • 按向上、向下、向左、向右、鼠标滚轮等键...无论您想要什么，但在 Memo2 上查看它的实际效果

我将尝试通过以下方式对其进行改进：在 Memo2 上执行某些操作时，Memo1 滚动仍处于同步状态...

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

于 2012-11-05T13:02:14.703 回答
2

正如我告诉...

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

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

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

这第一部分只是为 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 必须同步的另一个 Memo 是什么。

在您的实施部分，为 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返回零的问题！！！

于 2012-11-06T13:18:28.880 回答
2

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

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

棘手的部分：

  • 将 TPanel 放在 TMemo 所在的位置，然后将 TMemo 放在 TPanel 内
  • 隐藏TPanel边框，将BorderWith设为0，所有Bevel为bvNone/bkNone
  • 将 TMemo Align 配置为 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。

于 2012-11-08T08:13:45.557 回答
1

感谢GetSystemMetricsand SM_CYHSCROLL，但这还不够……只需要多 3 个像素……

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

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

非常感谢。

如果您愿意，只需将它们加入一个大帖子，但我认为最好不要混合它们。

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

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

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

于 2012-11-21T14:12:27.087 回答